regsamp
asked on
Excel Master Time sheet gives runtime error '5'
We have an Excel Master Time Sheet that we have custom macros that we created and they work fine but if anyone opens up any other Excel file, both Excel files will give a message saying "Run-time error '5' and Invalid procedure call or argument." It as if the macros see another Excel file open and try to run something. We did not create the macros and this is a little new for us so anyone that can assist us and helping to allow us to open multiple Excel time sheets at once without the error is greatly appreciated.
Sub Clear_Cells()
Dim Count As Integer
Dim LstLine As Boolean
Dim LstCell As Range
Dim Flag, FstAdd, LstAdd, Rnge As String
Count = 4
LstLine = False
Flag = "last line"
FstAdd = "D4"
ActiveSheet.Unprotect
Do Until LstLine = True
Set LstCell = Cells(Count, 2).Find(Flag)
If Not LstCell Is Nothing Then
LstAdd = LstCell.Address
LstLine = True
Else
Count = Count + 1
End If
Loop
If Len(LstAdd) = 4 Then
LstAdd = Right(LstAdd, 1)
ElseIf Len(LstAdd) = 5 Then
LstAdd = Right(LstAdd, 2)
ElseIf Len(LstAdd) = 6 Then
LstAdd = Right(LstAdd, 3)
Else
LstAdd = Right(LstAdd, 4)
End If
LstAdd = "J" & LstAdd
Rnge = FstAdd & ":" & LstAdd
Range(Rnge).Select
Selection.ClearContents
Range("A3").Activate
ActiveSheet.Protect
End Sub
Sub TimeSheet_Print()
ActiveSheet.Unprotect
Range("K4").Select
Selection.AutoFilter
Selection.AutoFilter Field:=11, Criteria1:="<>"
Columns("A:L").Select
ActiveWindow.Selection.PrintOut Copies:=1
Selection.AutoFilter
ActiveWindow.ScrollColumn = 1
Range("B2").Select
CommandBars("TEST").Controls(1).State = msoButtonUp
ActiveSheet.Protect
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.CommandBars("TEST").Delete
End Sub
Private Sub Workbook_Open()
Set mybar = Application.CommandBars _
.Add(Name:="TEST", Position:=msoBarTop)
mybar.Visible = True
mybar.Enabled = True
Set myCntrl = mybar.Controls.Add(Type:=msoControlButton, ID:=1)
With myCntrl
.Style = msoButtonIconAndCaption
.OnAction = "Clear_Cells"
.Caption = "Clear Cells"
.Visible = True
End With
Set myCntrl = mybar.Controls.Add(Type:=msoControlButton, ID:=1)
With myCntrl
.Style = msoButtonIconAndCaption
.OnAction = "TimeSheet_Print"
.Caption = "Print Timesheet"
.Visible = True
End With
Set myCntrl = mybar.Controls.Add(Type:=msoControlButton, ID:=1)
With myCntrl
.Style = msoButtonIconAndCaption
.OnAction = "JobFinder"
.Caption = "Job Finder"
.Visible = True
End With
Set myCntrl = mybar.Controls.Add(Type:=msoControlButton, ID:=1)
With myCntrl
.Style = msoButtonIconAndCaption
.OnAction = "ClearJobFinder"
.Caption = "Clear Job Finder Page"
.Visible = True
End With
Sheets("TimeSheet").Select
Range("B1").Select
ActiveSheet.Protect
End Sub
ASKER
Yes, when we have it open, it is capturing the opening of another workbook. The rest of the code that I found in other sections is listed below.
Dim TextSearch As Boolean
Private Sub cmdSearch_Click()
SearchJobs
End Sub
Sub SearchJobs()
Dim strSQL As String, sConn As String, oCn As ADODB.Connection, rsRecs As ADODB.Recordset
Dim CurRow As Integer, WkSht As Excel.Worksheet
On Error GoTo Error_Handler
sConn = "Provider=SQLOLEDB;Data Source=test;User ID=sa;Password=;Initial Catalog=dwma"
Set WkSht = Application.Sheets("JobFin der")
WkSht.Select
Columns("A:C").Select
Selection.Clear
Selection.Borders(xlDiagon alDown).Li neStyle = xlNone
Selection.Borders(xlDiagon alUp).Line Style = xlNone
With Selection.Borders(xlEdgeLe ft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTo p)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBo ttom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRi ght)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInside Vertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInside Horizontal )
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
strSQL = "SELECT p.ProjectsID As ProjectsID, p.ProjNum As ProjNum, t.ProjNum As TaskNum, p.ProjName As ProjName, t.Description As Description," & _
" p.Status As Status, t.Status As tStatus, p.Exp, p.Bill_Level As Bill_Level, t.Bill_Level As tBill_Level," & _
" p.Prin As Prin, p.PM As PM, p.PSM As PSM, t.Prin As tPrin, t.PM As tPM, t.PSM As tPSM, c.Client_Name As Client_Name, p.Exp As Exp" & _
" FROM ((Projects p LEFT JOIN Clients c ON p.ClientID = c.ClientID)" & _
" LEFT JOIN Tasks t ON p.ProjectsID = t.ProjectID) WHERE p.Status = 'A' AND t.Status = 'A'"
If TextSearch Then
strSQL = strSQL & " AND p.ProjNum LIKE '" & txtSearch & "%' OR t.ProjNum LIKE '" & txtSearch & "%' OR p.ProjName LIKE '" & txtSearch & "%' OR t.Description LIKE '%" & txtSearch & "%'"
Else
If optDateSearch.Value = True And optAfter.Value = True Then
strSQL = strSQL & " AND (p.date_assigned >= '" & txtDate & "')"
ElseIf optDateSearch.Value = True And optBefore.Value = True Then
strSQL = strSQL & " AND (p.date_assigned <= '" & txtDate & "')"
End If
End If
strSQL = strSQL & " ORDER BY p.ProjNum, t.ProjNum"
Set oCn = New ADODB.Connection
oCn.Open sConn
Set rsRecs = New ADODB.Recordset
rsRecs.CursorLocation = adUseClient
rsRecs.Open strSQL, oCn, 1, 2, 1
CurRow = 1
Do Until rsRecs.EOF
If rsRecs("TaskNum") = "" Then
WkSht.Cells(CurRow, 1) = rsRecs("ProjNum")
Else
WkSht.Cells(CurRow, 1) = rsRecs("TaskNum")
End If
WkSht.Cells(CurRow, 2) = rsRecs("ProjName") & " " & rsRecs("Description")
CurRow = CurRow + 1
rsRecs.MoveNext
Loop
Sheets("JobFinder").Select
Unload Me
Exit Sub
Error_Handler:
MsgBox "Error in entry. Please type the correct date format." & vbCrLf & "Error #" & Err.Number & vbCrLf & "Description: " & Err.Description, vbExclamation + vbOKOnly, "Error in entry"
End Sub
Private Sub optDateSearch_Click()
txtSearch.Enabled = False
lblSearch.Enabled = False
optAfter.Enabled = True
optBefore.Enabled = True
txtDate.Enabled = True
lblDate.Enabled = True
TextSearch = False
End Sub
Private Sub optTextSearch_Click()
txtSearch.Enabled = True
lblSearch.Enabled = True
optAfter.Enabled = False
optBefore.Enabled = False
txtDate.Enabled = False
lblDate.Enabled = False
TextSearch = True
End Sub
Private Sub UserForm_Activate()
TextSearch = True
End Sub
Sub JobFinder()
frmJobFinder.Show
End Sub
Sub ClearJobFinder()
Sheets("JobFinder").Select
Columns("A:B").Select
Selection.ClearContents
Selection.QueryTable.Delet e
Range("A1").Select
Sheets("TimeSheet").Select
Range("B1").Select
End Sub
Dim TextSearch As Boolean
Private Sub cmdSearch_Click()
SearchJobs
End Sub
Sub SearchJobs()
Dim strSQL As String, sConn As String, oCn As ADODB.Connection, rsRecs As ADODB.Recordset
Dim CurRow As Integer, WkSht As Excel.Worksheet
On Error GoTo Error_Handler
sConn = "Provider=SQLOLEDB;Data Source=test;User ID=sa;Password=;Initial Catalog=dwma"
Set WkSht = Application.Sheets("JobFin
WkSht.Select
Columns("A:C").Select
Selection.Clear
Selection.Borders(xlDiagon
Selection.Borders(xlDiagon
With Selection.Borders(xlEdgeLe
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTo
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBo
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRi
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInside
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInside
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
strSQL = "SELECT p.ProjectsID As ProjectsID, p.ProjNum As ProjNum, t.ProjNum As TaskNum, p.ProjName As ProjName, t.Description As Description," & _
" p.Status As Status, t.Status As tStatus, p.Exp, p.Bill_Level As Bill_Level, t.Bill_Level As tBill_Level," & _
" p.Prin As Prin, p.PM As PM, p.PSM As PSM, t.Prin As tPrin, t.PM As tPM, t.PSM As tPSM, c.Client_Name As Client_Name, p.Exp As Exp" & _
" FROM ((Projects p LEFT JOIN Clients c ON p.ClientID = c.ClientID)" & _
" LEFT JOIN Tasks t ON p.ProjectsID = t.ProjectID) WHERE p.Status = 'A' AND t.Status = 'A'"
If TextSearch Then
strSQL = strSQL & " AND p.ProjNum LIKE '" & txtSearch & "%' OR t.ProjNum LIKE '" & txtSearch & "%' OR p.ProjName LIKE '" & txtSearch & "%' OR t.Description LIKE '%" & txtSearch & "%'"
Else
If optDateSearch.Value = True And optAfter.Value = True Then
strSQL = strSQL & " AND (p.date_assigned >= '" & txtDate & "')"
ElseIf optDateSearch.Value = True And optBefore.Value = True Then
strSQL = strSQL & " AND (p.date_assigned <= '" & txtDate & "')"
End If
End If
strSQL = strSQL & " ORDER BY p.ProjNum, t.ProjNum"
Set oCn = New ADODB.Connection
oCn.Open sConn
Set rsRecs = New ADODB.Recordset
rsRecs.CursorLocation = adUseClient
rsRecs.Open strSQL, oCn, 1, 2, 1
CurRow = 1
Do Until rsRecs.EOF
If rsRecs("TaskNum") = "" Then
WkSht.Cells(CurRow, 1) = rsRecs("ProjNum")
Else
WkSht.Cells(CurRow, 1) = rsRecs("TaskNum")
End If
WkSht.Cells(CurRow, 2) = rsRecs("ProjName") & " " & rsRecs("Description")
CurRow = CurRow + 1
rsRecs.MoveNext
Loop
Sheets("JobFinder").Select
Unload Me
Exit Sub
Error_Handler:
MsgBox "Error in entry. Please type the correct date format." & vbCrLf & "Error #" & Err.Number & vbCrLf & "Description: " & Err.Description, vbExclamation + vbOKOnly, "Error in entry"
End Sub
Private Sub optDateSearch_Click()
txtSearch.Enabled = False
lblSearch.Enabled = False
optAfter.Enabled = True
optBefore.Enabled = True
txtDate.Enabled = True
lblDate.Enabled = True
TextSearch = False
End Sub
Private Sub optTextSearch_Click()
txtSearch.Enabled = True
lblSearch.Enabled = True
optAfter.Enabled = False
optBefore.Enabled = False
txtDate.Enabled = False
lblDate.Enabled = False
TextSearch = True
End Sub
Private Sub UserForm_Activate()
TextSearch = True
End Sub
Sub JobFinder()
frmJobFinder.Show
End Sub
Sub ClearJobFinder()
Sheets("JobFinder").Select
Columns("A:B").Select
Selection.ClearContents
Selection.QueryTable.Delet
Range("A1").Select
Sheets("TimeSheet").Select
Range("B1").Select
End Sub
Okay, there doesn't seem to be anything there to cause that behaviour. Can you post your workbook? If not, when you get the runtime error, press debug and let us know which line it is falling over on.
ASKER
This is the line it goes on when we press debug:
Set mybar = Application.CommandBars _
.Add(Name:="DWMA", Position:=msoBarTop)
Set mybar = Application.CommandBars _
.Add(Name:="DWMA", Position:=msoBarTop)
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Yes, the second workbook contains the same worksheet_open code as the first. Is there anyway around it or if it is has the same code then it it will have this behavior?
You are trying to add a toolbar that already exists. You could give the toolbar a different name - you'd have two that look the same but control the two different workbooks. You could check if the bar exists and only create it if it doesn't, and then keep a record of this so you don't destroy it if the workbook is closed - but then you wouldn't have a bar to control that second book. It really depends on the purpose of having the same bar created by two different workbooks.
ASKER
Well, the toolbar is an option that is on every time sheet so I know there must be away but I don't enough to tell Excel if another file opens with the same toobar, not to create? I guess it would be easier that some of the Manager's had time sheets that did not have the toobar option and could use those in conjunction with the ones that did have it.
ASKER
Well, you have helped me out Jaffa0. Thank you for your help.
Is that the only code? I'm thinking that there may be a class module capturing events - it will have something like
Private WithEvents App As Application
Private Sub Class_Initialize()
Set App = Application
End Sub
in it.