wrt1mea
asked on
VBA Error
I have been working on theis excel Report to import data. A friend of mine has been wirting the code. It is working on his end, but not on mine as I am getting the following errors (see attached as well)
When I select "IMPORT" I get a Microsoft Visual Basic Run time Error 424
He has prompted me to install a new comdlg32.ocx file in the directory C:\windows\system32, which I have done and attempted to register using the following command: regsvr32 comdlg32.ocx. When I do that I get a regsvr32 error stating that the module failed to load.
I am trying to run this macro on a Windows 7 Enterprise Machine with Office 2007 Professional
See the attached for errors and the VB code information
Regsvr32-Error.png
When I select "IMPORT" I get a Microsoft Visual Basic Run time Error 424
He has prompted me to install a new comdlg32.ocx file in the directory C:\windows\system32, which I have done and attempted to register using the following command: regsvr32 comdlg32.ocx. When I do that I get a regsvr32 error stating that the module failed to load.
I am trying to run this macro on a Windows 7 Enterprise Machine with Office 2007 Professional
See the attached for errors and the VB code information
Private Sub cmdImport_Click()
'Purpose: Import button for user to click (launches initial function).
Set wksMaster = Worksheets("MASTER") 'Set master worksheet reference to current workbook / MASTER sheet (tab). This tab name must not change or will need to be updated!
ImportDataFromWorksheet
Set wksMaster = Nothing 'Dispose object; do not close workbook as user is still using [THIS] workbook for importing . . .
ReDim arrProjectName(0): ReDim arrAccountingCode(0): ReDim arrStatus(0) 'Empty all used arrays
ReDim arrEntity(0): ReDim arrMileage(0): ReDim arrTotals(0) 'Empty all used arrays
End Sub
Public Function ImportDataFromWorksheet()
'Purpose: Open source worksheet to gather data from and run remaining functions.
Dim wksFileName As String
SelectWorksheet:
CommonDialog1.Filename = ""
CommonDialog1.DialogTitle = "Select Workbook to Import From"
CommonDialog1.Filter = "Excel Spreadsheets (*.xls*) | *.xls*"
CommonDialog1.ShowOpen
wksFileName = CommonDialog1.Filename
'Loop until valid workbook has been selected; will prompt user to try again if invalid or no workbook has been selected
If wksFileName = "" Then 'Means that user did not select a file. Maybe wants to cancel?
response = MsgBox("Worksheet not selected. Try again?", vbCritical + vbYesNoCancel, "Worksheet not selected")
If response = vbYes Then
GoTo SelectWorksheet
Else
MsgBox "Import Cancelled", vbInformation + vbOKOnly, "Import Cancelled"
'Cannot continue ... exit
Exit Function
End If
ElseIf FileExists(wksFileName) = False Then 'Check to see if selected file actually exists (in case user manually types a filename in the box rather than selecting from the list)
response = MsgBox("Selected file does not exist. Try again?", vbCritical + vbYesNoCancel, "File not found")
If response = vbYes Then
GoTo SelectWorksheet
Else
MsgBox "Import Cancelled", vbInformation + vbOKOnly, "Import Cancelled"
End If
Else
'MsgBox "File found: " & wksFileName, vbInformation + vbOKOnly, "File found"
Set wbkForecast = Workbooks.Open(wksFileName, , True) 'Opens selected workbook in READ-ONLY mode so there are no changes made to it!
GetSourceData
wbkForecast.Close 'Close the source (selected) workbook
Set wbkForecast = Nothing 'Dispose object
wksFileName = "" 'Clear filename
CommonDialog1.Filename = "" 'Clear object filename
If ALLOW_MODIFY_WITHOUT_WARNING = True Then
'User has already turned off modification warning; don't worry about setting it again
PopulateMasterSpreadsheet
Else
'Turn off modification warning!
ALLOW_MODIFY_WITHOUT_WARNING = True
PopulateMasterSpreadsheet
'Turn on modification warning!
ALLOW_MODIFY_WITHOUT_WARNING = False
End If
Exit Function
End If
End Function
Private Function GetSourceData()
'Purpose: Gather all of the data from the source (selected) worksheet
Dim strRangeToUse As String, iCounter As Integer, iNumRecords As Integer
Set wksForecast = wbkForecast.Sheets("Projects") 'Selects the SOURCE worksheet. The name of this tab must not change or will need to be updated! (Current tab name: Projects)
iNumRecords = 0 'Initialize
ReDim arrProjectName(iNumRecords): ReDim arrAccountingCode(iNumRecords): ReDim arrStatus(iNumRecords)
ReDim arrEntity(iNumRecords): ReDim arrMileage(iNumRecords): ReDim arrTotals(iNumRecords)
arrOtherData(0) = wksForecast.Range("H6").Value 'Name
arrOtherData(1) = wksForecast.Range("H8").Value 'Position
arrOtherData(2) = wksForecast.Range("P6").Value 'Company
strRangeToUse = "AJ16" 'Initialize
iCounter = 0 'Initialize
Do Until iCounter >= 10
If wksForecast.Range(strRangeToUse).Value <> "" And wksForecast.Range(strRangeToUse).Value <> 0 Then
ReDim Preserve arrProjectName(iNumRecords): ReDim Preserve arrAccountingCode(iNumRecords): ReDim Preserve arrStatus(iNumRecords)
ReDim Preserve arrEntity(iNumRecords): ReDim Preserve arrMileage(iNumRecords): ReDim Preserve arrTotals(iNumRecords)
arrTotals(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'AJxx' (Totals)
strRangeToUse = "A" & Mid(strRangeToUse, 3)
arrProjectName(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'Axx' (Project Name)
strRangeToUse = "B" & Mid(strRangeToUse, 2)
arrAccountingCode(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'Bxx' (Accounting Code)
strRangeToUse = "C" & Mid(strRangeToUse, 2)
arrStatus(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'Cxx' (Status)
strRangeToUse = "D" & Mid(strRangeToUse, 2)
arrEntity(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'Dxx' (Entity)
strRangeToUse = "E" & Mid(strRangeToUse, 2)
arrMileage(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'Exx' (Mileage)
strRangeToUse = "AJ" & Trim(Str(Val(Mid(strRangeToUse, 2)) + 1))
iNumRecords = iNumRecords + 1
iCounter = 0
Else
iCounter = iCounter + 1 'Loop until there is no more data on the sheet.
End If
Loop
End Function
Private Function PopulateMasterSpreadsheet()
'Purpose: Populate the current MASTER worksheet of the MASTER workbook with the collected data and apply basic formatting to the cells.
Dim strRangeToUse As String, iCounter As Integer, iNumRecords As Integer
strRangeToUse = "A1" 'Initialize
'Find the next free cell to use . . .
'If there is no data in the MASTER worksheet, it will start entering data on line A4 ... this can be changed by expliciting telling it where to start (after this loop statement) if cells A1 through A4
'are empty ... not sure if this would be the intended functionality. Otherwise, it will start on the 4th free cell if there is data already on the sheet.
'NOTE: The MASTER worksheet should not be "modified" by the user to remove a row of data and leaving an additional blank row ... this could cause existing data to be overwritten by the script
Do Until iCounter >= NUM_BLANK_ROWS_TO_CHECK 'Check for x consecutive blank cells (Column A) and start entering data on the xth free cell. Modify this constant as necessary.
If wksMaster.Range(strRangeToUse).Value <> "" Then
iCounter = 0
Else
iCounter = iCounter + 1
End If
strRangeToUse = "A" & Trim(Str(Val(Mid(strRangeToUse, 2)) + 1))
Loop
strRangeToUse = "A" & Trim(Str(Val(Mid(strRangeToUse, 2)) - 1))
wksMaster.Range(strRangeToUse).Value = "NAME" 'User Name Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlLeft
strRangeToUse = "B" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "COMPANY" 'Company Name Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlLeft
strRangeToUse = "C" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "POSITION" 'Position Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlLeft
strRangeToUse = "D" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "PROJECT NAME" 'Project Name Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlLeft
strRangeToUse = "E" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "ACCOUNTING CODE" 'Accounting Code Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlLeft
strRangeToUse = "F" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "STATUS" 'Status Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlCenter
strRangeToUse = "G" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "ENTITY" 'Entity Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlCenter
strRangeToUse = "H" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "MILEAGE" 'Mileage Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlCenter
strRangeToUse = "I" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "TOTALS" 'Totals Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlCenter
strRangeToUse = "A" & Trim(Str(Val(Mid(strRangeToUse, 2)) + 1)) 'Initialize for data entry
For i = 0 To UBound(arrProjectName())
wksMaster.Range(strRangeToUse).Value = arrOtherData(0) 'User Name
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "B" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrOtherData(2) 'Company Name
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "C" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrOtherData(1) 'Position
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "D" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrProjectName(i) 'Project Name
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "E" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrAccountingCode(i) 'Accounting Code
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "F" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrStatus(i) 'Status
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "G" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrEntity(i) 'Entity
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "H" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrMileage(i) 'Mileage
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlCenter
strRangeToUse = "I" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrTotals(i) 'Totals
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlRight
wksMaster.Range(strRangeToUse).NumberFormat = "$#,##0.00"
strRangeToUse = "A" & Trim(Str(Val(Mid(strRangeToUse, 2)) + 1)) 'Initialize for next entry
Next i
MsgBox "Import Complete!", vbInformation + vbOKOnly, "Import Complete"
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
If ALLOW_MODIFY_WITHOUT_WARNING = False Then
response = MsgBox("If you modify this worksheet, be careful not to leave additional blank lines between data entries (currently set to " & Trim(Str(NUM_BLANK_ROWS_TO_CHECK - 1)) & " blank rows) or the Import macro may overwrite existing data! Disable modification warning?", vbCritical + vbYesNo, "Modification Warning")
If response = vbYes Then ALLOW_MODIFY_WITHOUT_WARNING = True
End If
End Sub
VB-Runtime-Error-424.pngRegsvr32-Error.png
ASKER
OK, I updated the line like you said and am getting the following error message: "Run Time Error 429
See attached.
Run-Time-Error-429.png
See attached.
Run-Time-Error-429.png
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
OK, I tried that and I get a "Compile Error: Label Not Defined" on Line 45
It then Highlights "Public Function ImportDataFromWorksheet () in yellow.
It then Highlights "Public Function ImportDataFromWorksheet () in yellow.
Sorry - I should have said replace 21-25 - you need the SelectWorksheet label.
ASKER
Alrighty...When I tried that it at Line 39 wksFileName = CommonDialog1.Filename, I get another Runtime error '424'
ASKER
And it might help to mention that I dont know CRAP about VB
With Andrew's solution that line should have been deleted. The original script you gave showed that line as line 25 and lines 21-25 should have been replaced with Andrew's solution.
ASKER
OK, I tried that and it errored out at line 66 "CommonDialog1.Filename = "". Since we change something at 21-15, what do I need to change this too?
Private Sub cmdImport_Click()
'Purpose: Import button for user to click (launches initial function).
Set wksMaster = Worksheets("MASTER") 'Set master worksheet reference to current workbook / MASTER sheet (tab). This tab name must not change or will need to be updated!
ImportDataFromWorksheet
Set wksMaster = Nothing 'Dispose object; do not close workbook as user is still using [THIS] workbook for importing . . .
ReDim arrProjectName(0): ReDim arrAccountingCode(0): ReDim arrStatus(0) 'Empty all used arrays
ReDim arrEntity(0): ReDim arrMileage(0): ReDim arrTotals(0) 'Empty all used arrays
End Sub
Public Function ImportDataFromWorksheet()
'Purpose: Open source worksheet to gather data from and run remaining functions.
Dim wksFileName As String
SelectWorksheet:
Dim dlg As Office.FileDialog
Set dlg = Application.FileDialog(msoFileDialogOpen)
With dlg
.AllowMultiSelect = False
.InitialFileName = ""
.Title = "Select Workbook to Import From"
.Filters.Clear
.Filters.Add "Excel Spreadsheets", "*.xls*"
If .Show Then
wksFileName = .SelectedItems(1)
Else
wksFileName = ""
End If
End With
'Loop until valid workbook has been selected; will prompt user to try again if invalid or no workbook has been selected
If wksFileName = "" Then 'Means that user did not select a file. Maybe wants to cancel?
response = MsgBox("Worksheet not selected. Try again?", vbCritical + vbYesNoCancel, "Worksheet not selected")
If response = vbYes Then
GoTo SelectWorksheet
Else
MsgBox "Import Cancelled", vbInformation + vbOKOnly, "Import Cancelled"
'Cannot continue ... exit
Exit Function
End If
ElseIf FileExists(wksFileName) = False Then 'Check to see if selected file actually exists (in case user manually types a filename in the box rather than selecting from the list)
response = MsgBox("Selected file does not exist. Try again?", vbCritical + vbYesNoCancel, "File not found")
If response = vbYes Then
GoTo SelectWorksheet
Else
MsgBox "Import Cancelled", vbInformation + vbOKOnly, "Import Cancelled"
End If
Else
'MsgBox "File found: " & wksFileName, vbInformation + vbOKOnly, "File found"
Set wbkForecast = Workbooks.Open(wksFileName, , True) 'Opens selected workbook in READ-ONLY mode so there are no changes made to it!
GetSourceData
wbkForecast.Close 'Close the source (selected) workbook
Set wbkForecast = Nothing 'Dispose object
wksFileName = "" 'Clear filename
CommonDialog1.Filename = "" 'Clear object filename
Ah, good find. Anywhere with CommonDialog1 needs to be altered. In this case you can just remove that line or change it to:
dlg.FileName = ""
I'm not really sure why the file name for the dialog box that doesn't appear anymore needs to be cleared, but you never know. If removing it returns errors, try changing it to the above.
ASKER
OK, when I added the line, I got a "compile error; Method or data member not found.
When I removed it, I get a Runtime error '91': Object Variable or With Block variable not set.
My apoligies for not knowing more...
When I removed it, I get a Runtime error '91': Object Variable or With Block variable not set.
My apoligies for not knowing more...
Can you show the entire ImportDataFromWorksheet function? All the way to "End Function". I realize why dlg.FileName doesn't work (dumb mistake on my part, I was still thinking about the solution I mentiioned earlier), but I'm wondering if the error your encountering is somewhere else in the function.
ASKER
I can post the entire code, including the changes from andrewssd3
Is that what you are wanting?
Is that what you are wanting?
Private Sub cmdImport_Click()
'Purpose: Import button for user to click (launches initial function).
Set wksMaster = Worksheets("MASTER") 'Set master worksheet reference to current workbook / MASTER sheet (tab). This tab name must not change or will need to be updated!
ImportDataFromWorksheet
Set wksMaster = Nothing 'Dispose object; do not close workbook as user is still using [THIS] workbook for importing . . .
ReDim arrProjectName(0): ReDim arrAccountingCode(0): ReDim arrStatus(0) 'Empty all used arrays
ReDim arrEntity(0): ReDim arrMileage(0): ReDim arrTotals(0) 'Empty all used arrays
End Sub
Public Function ImportDataFromWorksheet()
'Purpose: Open source worksheet to gather data from and run remaining functions.
Dim wksFileName As String
SelectWorksheet:
Dim dlg As Office.FileDialog
Set dlg = Application.FileDialog(msoFileDialogOpen)
With dlg
.AllowMultiSelect = False
.InitialFileName = ""
.Title = "Select Workbook to Import From"
.Filters.Clear
.Filters.Add "Excel Spreadsheets", "*.xls*"
If .Show Then
wksFileName = .SelectedItems(1)
Else
wksFileName = ""
End If
End With
'Loop until valid workbook has been selected; will prompt user to try again if invalid or no workbook has been selected
If wksFileName = "" Then 'Means that user did not select a file. Maybe wants to cancel?
response = MsgBox("Worksheet not selected. Try again?", vbCritical + vbYesNoCancel, "Worksheet not selected")
If response = vbYes Then
GoTo SelectWorksheet
Else
MsgBox "Import Cancelled", vbInformation + vbOKOnly, "Import Cancelled"
'Cannot continue ... exit
Exit Function
End If
ElseIf FileExists(wksFileName) = False Then 'Check to see if selected file actually exists (in case user manually types a filename in the box rather than selecting from the list)
response = MsgBox("Selected file does not exist. Try again?", vbCritical + vbYesNoCancel, "File not found")
If response = vbYes Then
GoTo SelectWorksheet
Else
MsgBox "Import Cancelled", vbInformation + vbOKOnly, "Import Cancelled"
End If
Else
'MsgBox "File found: " & wksFileName, vbInformation + vbOKOnly, "File found"
Set wbkForecast = Workbooks.Open(wksFileName, , True) 'Opens selected workbook in READ-ONLY mode so there are no changes made to it!
GetSourceData
wbkForecast.Close 'Close the source (selected) workbook
Set wbkForecast = Nothing 'Dispose object
wksFileName = "" 'Clear filename
CommonDialog1.Filename = "" 'Clear object filename
If ALLOW_MODIFY_WITHOUT_WARNING = True Then
'User has already turned off modification warning; don't worry about setting it again
PopulateMasterSpreadsheet
Else
'Turn off modification warning!
ALLOW_MODIFY_WITHOUT_WARNING = True
PopulateMasterSpreadsheet
'Turn on modification warning!
ALLOW_MODIFY_WITHOUT_WARNING = False
End If
Exit Function
End If
End Function
Private Function GetSourceData()
'Purpose: Gather all of the data from the source (selected) worksheet
Dim strRangeToUse As String, iCounter As Integer, iNumRecords As Integer
Set wksForecast = wbkForecast.Sheets("Projects") 'Selects the SOURCE worksheet. The name of this tab must not change or will need to be updated! (Current tab name: Projects)
iNumRecords = 0 'Initialize
ReDim arrProjectName(iNumRecords): ReDim arrAccountingCode(iNumRecords): ReDim arrStatus(iNumRecords)
ReDim arrEntity(iNumRecords): ReDim arrMileage(iNumRecords): ReDim arrTotals(iNumRecords)
arrOtherData(0) = wksForecast.Range("H6").Value 'Name
arrOtherData(1) = wksForecast.Range("H8").Value 'Position
arrOtherData(2) = wksForecast.Range("P6").Value 'Company
strRangeToUse = "AJ16" 'Initialize
iCounter = 0 'Initialize
Do Until iCounter >= 10
If wksForecast.Range(strRangeToUse).Value <> "" And wksForecast.Range(strRangeToUse).Value <> 0 Then
ReDim Preserve arrProjectName(iNumRecords): ReDim Preserve arrAccountingCode(iNumRecords): ReDim Preserve arrStatus(iNumRecords)
ReDim Preserve arrEntity(iNumRecords): ReDim Preserve arrMileage(iNumRecords): ReDim Preserve arrTotals(iNumRecords)
arrTotals(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'AJxx' (Totals)
strRangeToUse = "A" & Mid(strRangeToUse, 3)
arrProjectName(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'Axx' (Project Name)
strRangeToUse = "B" & Mid(strRangeToUse, 2)
arrAccountingCode(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'Bxx' (Accounting Code)
strRangeToUse = "C" & Mid(strRangeToUse, 2)
arrStatus(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'Cxx' (Status)
strRangeToUse = "D" & Mid(strRangeToUse, 2)
arrEntity(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'Dxx' (Entity)
strRangeToUse = "E" & Mid(strRangeToUse, 2)
arrMileage(iNumRecords) = wksForecast.Range(strRangeToUse).Value 'Exx' (Mileage)
strRangeToUse = "AJ" & Trim(Str(Val(Mid(strRangeToUse, 2)) + 1))
iNumRecords = iNumRecords + 1
iCounter = 0
Else
iCounter = iCounter + 1 'Loop until there is no more data on the sheet.
End If
Loop
End Function
Private Function PopulateMasterSpreadsheet()
'Purpose: Populate the current MASTER worksheet of the MASTER workbook with the collected data and apply basic formatting to the cells.
Dim strRangeToUse As String, iCounter As Integer, iNumRecords As Integer
strRangeToUse = "A1" 'Initialize
'Find the next free cell to use . . .
'If there is no data in the MASTER worksheet, it will start entering data on line A4 ... this can be changed by expliciting telling it where to start (after this loop statement) if cells A1 through A4
'are empty ... not sure if this would be the intended functionality. Otherwise, it will start on the 4th free cell if there is data already on the sheet.
'NOTE: The MASTER worksheet should not be "modified" by the user to remove a row of data and leaving an additional blank row ... this could cause existing data to be overwritten by the script
Do Until iCounter >= NUM_BLANK_ROWS_TO_CHECK 'Check for x consecutive blank cells (Column A) and start entering data on the xth free cell. Modify this constant as necessary.
If wksMaster.Range(strRangeToUse).Value <> "" Then
iCounter = 0
Else
iCounter = iCounter + 1
End If
strRangeToUse = "A" & Trim(Str(Val(Mid(strRangeToUse, 2)) + 1))
Loop
strRangeToUse = "A" & Trim(Str(Val(Mid(strRangeToUse, 2)) - 1))
wksMaster.Range(strRangeToUse).Value = "NAME" 'User Name Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlLeft
strRangeToUse = "B" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "COMPANY" 'Company Name Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlLeft
strRangeToUse = "C" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "POSITION" 'Position Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlLeft
strRangeToUse = "D" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "PROJECT NAME" 'Project Name Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlLeft
strRangeToUse = "E" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "ACCOUNTING CODE" 'Accounting Code Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlLeft
strRangeToUse = "F" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "STATUS" 'Status Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlCenter
strRangeToUse = "G" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "ENTITY" 'Entity Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlCenter
strRangeToUse = "H" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "MILEAGE" 'Mileage Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlCenter
strRangeToUse = "I" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = "TOTALS" 'Totals Label
wksMaster.Range(strRangeToUse).Font.Bold = True
wksMaster.Range(strRangeToUse).Cells.HorizontalAlignment = xlCenter
strRangeToUse = "A" & Trim(Str(Val(Mid(strRangeToUse, 2)) + 1)) 'Initialize for data entry
For i = 0 To UBound(arrProjectName())
wksMaster.Range(strRangeToUse).Value = arrOtherData(0) 'User Name
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "B" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrOtherData(2) 'Company Name
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "C" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrOtherData(1) 'Position
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "D" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrProjectName(i) 'Project Name
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "E" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrAccountingCode(i) 'Accounting Code
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "F" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrStatus(i) 'Status
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "G" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrEntity(i) 'Entity
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlLeft
strRangeToUse = "H" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrMileage(i) 'Mileage
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlCenter
strRangeToUse = "I" & Mid(strRangeToUse, 2)
wksMaster.Range(strRangeToUse).Value = arrTotals(i) 'Totals
wksMaster.Range(strRangeToUse).Font.Bold = False
wksMaster.Range(strRangeToUse).HorizontalAlignment = xlRight
wksMaster.Range(strRangeToUse).NumberFormat = "$#,##0.00"
strRangeToUse = "A" & Trim(Str(Val(Mid(strRangeToUse, 2)) + 1)) 'Initialize for next entry
Next i
MsgBox "Import Complete!", vbInformation + vbOKOnly, "Import Complete"
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
If ALLOW_MODIFY_WITHOUT_WARNING = False Then
response = MsgBox("If you modify this worksheet, be careful not to leave additional blank lines between data entries (currently set to " & Trim(Str(NUM_BLANK_ROWS_TO_CHECK - 1)) & " blank rows) or the Import macro may overwrite existing data! Disable modification warning?", vbCritical + vbYesNo, "Modification Warning")
If response = vbYes Then ALLOW_MODIFY_WITHOUT_WARNING = True
End If
End Sub
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
I removed the line again and tried it but am still getting the runtime error 91. When I select OK to the error, it returns the cursor to line 66.
Thanks for your help and your patience.
Thanks for your help and your patience.
ASKER
OK, not sure what happened, but I removed that line. Saved it and closed it. Once I did that, the import ran like its supposed to and no errors! Thanks for the help and the dedication!
Thanks a million!
Thanks a million!
Open in new window