Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Looping Macro - Run Time Error
Dear All.
I have managed to piece together a complex code to perform a series of actions for me. The macro allows the user to select the folder containing the most up to date data, it then open each of the text files in that folder and converts them to excel files. Then I am trying to get it to copy and paste the data in each of those files onto the relevant sheet of the master workbook. I am trying to do this by matching the beginning of the file name and the beginning of the sheet name (so the macro knows where to put each files information). I am getting a run time error (424) though and can not figure out what it is that I need to define to make this process work. I am still quite new to VBA and have pieced this together from other codes which performed bits of the process that I am looking to do. I would welcome any advice on this please! Thanks. Liz. (Code is set out below): '32-bit API declarations (BT) Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Sub Commissioner() 'Switch off screen flashing Application.ScreenUpdating = False 'Turn off auto calculation With Application .Calculation = xlManual .MaxChange = 0.001 End With ActiveWorkbook.PrecisionAsDisplayed = False 'Request the user to select the folder containing the latest commissioner data Msg = "Select the folder containing the latest COMMISSIONER data" DDirectory = GetDirectory(Msg) If DDirectory = "" Then Exit Sub If Right(DDirectory, 1) < "\" Then DDirectory = DDirectory & "\" a = MsgBox(Prompt:=DDirectory, Buttons:=vbOKOnly) 'Open each text file and save it as an excel file ChDir DDirectory Set fso = CreateObject("Scripting.FileSystemObject").GetFold er(DDirectory) For Each file In fso.Files If file.Type = "Text Document" Then With file Workbooks.OpenText Filename:=file.Name _ , Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _ Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _ Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _ Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), _ Array(16, 1), Array(17, 1), Array(18, 1)), TrailingMinusNumbers:=True ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Name & ".xls" _ , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False ActiveWorkbook.Close End With End If Next Set fso = Nothing 'Unhide all worksheets Windows("Cancer monitoring (Commissioner).xls").Activate Sheets("6.1 ReportDownload").Visible = True Sheets("6.2 ReportDownload").Visible = True Sheets("7.1 ReportDownload").Visible = True Sheets("7.2 ReportDownload").Visible = True Sheets("7.7 ReportDownload").Visible = True Sheets("7.8 ReportDownload").Visible = True Sheets("8.1 ReportDownload").Visible = True Sheets("8.2 ReportDownload").Visible = True Sheets("8.7 ReportDownload").Visible = True Sheets("9.1 ReportDownload").Visible = True Sheets("9.2 ReportDownload").Visible = True Sheets("10.1 ReportDownload").Visible = True Sheets("10.2 ReportDownload").Visible = True 'Open each Excel file and copy it into the model Dim strWSName As String Dim ws As Worksheet done = False Windows("Cancer monitoring (Commissioner).xls").Activate For Each ws In ActiveWorkbook.Worksheets If Left(ws.Name, 3) = Left(wbdatafile.Name, 3) Then wbdatafile.Open Range("A2").Select Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select Selection.Copy ThisWorkbook.Activate strWSName = wbdatafile.Name If SheetExists = True Then Worksheets(strWSName).Activate Range("B65536").End(xlUp).Offset(1, -1).Select ActiveSheet.Paste Range("B65536").End(xlUp).Offset(1, -1).Select wbdatafile.Activate ActiveWorkbook.Close done = True End If End If Exit For Next 'Rehide all worksheets Sheets("6.1 ReportDownload").Visible = False Sheets("6.2 ReportDownload").Visible = False Sheets("7.1 ReportDownload").Visible = False Sheets("7.2 ReportDownload").Visible = False Sheets("7.7 ReportDownload").Visible = False Sheets("7.8 ReportDownload").Visible = False Sheets("8.1 ReportDownload").Visible = False Sheets("8.2 ReportDownload").Visible = False Sheets("8.7 ReportDownload").Visible = False Sheets("9.1 ReportDownload").Visible = False Sheets("9.2 ReportDownload").Visible = False Sheets("10.1 ReportDownload").Visible = False Sheets("10.2 ReportDownload").Visible = False 'Switch on auto calculation With Application .Calculation = xlAutomatic .MaxChange = 0.001 End With ActiveWorkbook.PrecisionAsDisplayed = False 'Switch on screen flashing Application.ScreenUpdating = True End Sub 'More BT declarations Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer ' Root folder = Desktop bInfo.pidlRoot = 0& ' Title in the dialog If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If ' Type of directory to return bInfo.ulFlags = &H1 ' Display the dialog x = SHBrowseForFolder(bInfo) ' Parse the result path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Else GetDirectory = "" End If End Function |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Looping Macro - Run Time Error
Sorry, I forgot to mention that the line that the code breaks down on is as
follows: If Left(ws.Name, 3) = Left(wbdatafile.Name, 3) Then "BoRed79" wrote: Dear All. I have managed to piece together a complex code to perform a series of actions for me. The macro allows the user to select the folder containing the most up to date data, it then open each of the text files in that folder and converts them to excel files. Then I am trying to get it to copy and paste the data in each of those files onto the relevant sheet of the master workbook. I am trying to do this by matching the beginning of the file name and the beginning of the sheet name (so the macro knows where to put each files information). I am getting a run time error (424) though and can not figure out what it is that I need to define to make this process work. I am still quite new to VBA and have pieced this together from other codes which performed bits of the process that I am looking to do. I would welcome any advice on this please! Thanks. Liz. (Code is set out below): '32-bit API declarations (BT) Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Sub Commissioner() 'Switch off screen flashing Application.ScreenUpdating = False 'Turn off auto calculation With Application .Calculation = xlManual .MaxChange = 0.001 End With ActiveWorkbook.PrecisionAsDisplayed = False 'Request the user to select the folder containing the latest commissioner data Msg = "Select the folder containing the latest COMMISSIONER data" DDirectory = GetDirectory(Msg) If DDirectory = "" Then Exit Sub If Right(DDirectory, 1) < "\" Then DDirectory = DDirectory & "\" a = MsgBox(Prompt:=DDirectory, Buttons:=vbOKOnly) 'Open each text file and save it as an excel file ChDir DDirectory Set fso = CreateObject("Scripting.FileSystemObject").GetFold er(DDirectory) For Each file In fso.Files If file.Type = "Text Document" Then With file Workbooks.OpenText Filename:=file.Name _ , Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _ Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _ Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _ Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), _ Array(16, 1), Array(17, 1), Array(18, 1)), TrailingMinusNumbers:=True ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Name & ".xls" _ , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False ActiveWorkbook.Close End With End If Next Set fso = Nothing 'Unhide all worksheets Windows("Cancer monitoring (Commissioner).xls").Activate Sheets("6.1 ReportDownload").Visible = True Sheets("6.2 ReportDownload").Visible = True Sheets("7.1 ReportDownload").Visible = True Sheets("7.2 ReportDownload").Visible = True Sheets("7.7 ReportDownload").Visible = True Sheets("7.8 ReportDownload").Visible = True Sheets("8.1 ReportDownload").Visible = True Sheets("8.2 ReportDownload").Visible = True Sheets("8.7 ReportDownload").Visible = True Sheets("9.1 ReportDownload").Visible = True Sheets("9.2 ReportDownload").Visible = True Sheets("10.1 ReportDownload").Visible = True Sheets("10.2 ReportDownload").Visible = True 'Open each Excel file and copy it into the model Dim strWSName As String Dim ws As Worksheet done = False Windows("Cancer monitoring (Commissioner).xls").Activate For Each ws In ActiveWorkbook.Worksheets If Left(ws.Name, 3) = Left(wbdatafile.Name, 3) Then wbdatafile.Open Range("A2").Select Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select Selection.Copy ThisWorkbook.Activate strWSName = wbdatafile.Name If SheetExists = True Then Worksheets(strWSName).Activate Range("B65536").End(xlUp).Offset(1, -1).Select ActiveSheet.Paste Range("B65536").End(xlUp).Offset(1, -1).Select wbdatafile.Activate ActiveWorkbook.Close done = True End If End If Exit For Next 'Rehide all worksheets Sheets("6.1 ReportDownload").Visible = False Sheets("6.2 ReportDownload").Visible = False Sheets("7.1 ReportDownload").Visible = False Sheets("7.2 ReportDownload").Visible = False Sheets("7.7 ReportDownload").Visible = False Sheets("7.8 ReportDownload").Visible = False Sheets("8.1 ReportDownload").Visible = False Sheets("8.2 ReportDownload").Visible = False Sheets("8.7 ReportDownload").Visible = False Sheets("9.1 ReportDownload").Visible = False Sheets("9.2 ReportDownload").Visible = False Sheets("10.1 ReportDownload").Visible = False Sheets("10.2 ReportDownload").Visible = False 'Switch on auto calculation With Application .Calculation = xlAutomatic .MaxChange = 0.001 End With ActiveWorkbook.PrecisionAsDisplayed = False 'Switch on screen flashing Application.ScreenUpdating = True End Sub 'More BT declarations Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer ' Root folder = Desktop bInfo.pidlRoot = 0& ' Title in the dialog If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If ' Type of directory to return bInfo.ulFlags = &H1 ' Display the dialog x = SHBrowseForFolder(bInfo) ' Parse the result path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Else GetDirectory = "" End If End Function |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Looping Macro - Run Time Error
Unless I missed it, I don't see anywhere in the code you post where you
assign anything to wbdatafile... so what is VB supposed to do when you ask for its Name property? -- Rick (MVP - Excel) "BoRed79" wrote in message ... Dear All. I have managed to piece together a complex code to perform a series of actions for me. The macro allows the user to select the folder containing the most up to date data, it then open each of the text files in that folder and converts them to excel files. Then I am trying to get it to copy and paste the data in each of those files onto the relevant sheet of the master workbook. I am trying to do this by matching the beginning of the file name and the beginning of the sheet name (so the macro knows where to put each files information). I am getting a run time error (424) though and can not figure out what it is that I need to define to make this process work. I am still quite new to VBA and have pieced this together from other codes which performed bits of the process that I am looking to do. I would welcome any advice on this please! Thanks. Liz. (Code is set out below): '32-bit API declarations (BT) Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Sub Commissioner() 'Switch off screen flashing Application.ScreenUpdating = False 'Turn off auto calculation With Application .Calculation = xlManual .MaxChange = 0.001 End With ActiveWorkbook.PrecisionAsDisplayed = False 'Request the user to select the folder containing the latest commissioner data Msg = "Select the folder containing the latest COMMISSIONER data" DDirectory = GetDirectory(Msg) If DDirectory = "" Then Exit Sub If Right(DDirectory, 1) < "\" Then DDirectory = DDirectory & "\" a = MsgBox(Prompt:=DDirectory, Buttons:=vbOKOnly) 'Open each text file and save it as an excel file ChDir DDirectory Set fso = CreateObject("Scripting.FileSystemObject").GetFold er(DDirectory) For Each file In fso.Files If file.Type = "Text Document" Then With file Workbooks.OpenText Filename:=file.Name _ , Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _ Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _ Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _ Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), _ Array(16, 1), Array(17, 1), Array(18, 1)), TrailingMinusNumbers:=True ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Name & ".xls" _ , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False ActiveWorkbook.Close End With End If Next Set fso = Nothing 'Unhide all worksheets Windows("Cancer monitoring (Commissioner).xls").Activate Sheets("6.1 ReportDownload").Visible = True Sheets("6.2 ReportDownload").Visible = True Sheets("7.1 ReportDownload").Visible = True Sheets("7.2 ReportDownload").Visible = True Sheets("7.7 ReportDownload").Visible = True Sheets("7.8 ReportDownload").Visible = True Sheets("8.1 ReportDownload").Visible = True Sheets("8.2 ReportDownload").Visible = True Sheets("8.7 ReportDownload").Visible = True Sheets("9.1 ReportDownload").Visible = True Sheets("9.2 ReportDownload").Visible = True Sheets("10.1 ReportDownload").Visible = True Sheets("10.2 ReportDownload").Visible = True 'Open each Excel file and copy it into the model Dim strWSName As String Dim ws As Worksheet done = False Windows("Cancer monitoring (Commissioner).xls").Activate For Each ws In ActiveWorkbook.Worksheets If Left(ws.Name, 3) = Left(wbdatafile.Name, 3) Then wbdatafile.Open Range("A2").Select Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select Selection.Copy ThisWorkbook.Activate strWSName = wbdatafile.Name If SheetExists = True Then Worksheets(strWSName).Activate Range("B65536").End(xlUp).Offset(1, -1).Select ActiveSheet.Paste Range("B65536").End(xlUp).Offset(1, -1).Select wbdatafile.Activate ActiveWorkbook.Close done = True End If End If Exit For Next 'Rehide all worksheets Sheets("6.1 ReportDownload").Visible = False Sheets("6.2 ReportDownload").Visible = False Sheets("7.1 ReportDownload").Visible = False Sheets("7.2 ReportDownload").Visible = False Sheets("7.7 ReportDownload").Visible = False Sheets("7.8 ReportDownload").Visible = False Sheets("8.1 ReportDownload").Visible = False Sheets("8.2 ReportDownload").Visible = False Sheets("8.7 ReportDownload").Visible = False Sheets("9.1 ReportDownload").Visible = False Sheets("9.2 ReportDownload").Visible = False Sheets("10.1 ReportDownload").Visible = False Sheets("10.2 ReportDownload").Visible = False 'Switch on auto calculation With Application .Calculation = xlAutomatic .MaxChange = 0.001 End With ActiveWorkbook.PrecisionAsDisplayed = False 'Switch on screen flashing Application.ScreenUpdating = True End Sub 'More BT declarations Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer ' Root folder = Desktop bInfo.pidlRoot = 0& ' Title in the dialog If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If ' Type of directory to return bInfo.ulFlags = &H1 ' Display the dialog x = SHBrowseForFolder(bInfo) ' Parse the result path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Else GetDirectory = "" End If End Function |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Looping Macro - Run Time Error
Maybe I'm missing it by trying to read the code in your post, but I don't see
anywhere that you've set wbdatafile to any particular workbook. If you want it to be the same as the workbook you opened back in the For Each file in fso.Files loop, then you need to set the reference to it there, and wait until you are done with it later to close it, instead of closing it in that loop. Error 424 is "Object Required" error and I'm betting it's looking for the wbdatafile object so it can get the .Name property from it. Since it doesn't seem to exist yet, this is an impossible task. "BoRed79" wrote: Dear All. I have managed to piece together a complex code to perform a series of actions for me. The macro allows the user to select the folder containing the most up to date data, it then open each of the text files in that folder and converts them to excel files. Then I am trying to get it to copy and paste the data in each of those files onto the relevant sheet of the master workbook. I am trying to do this by matching the beginning of the file name and the beginning of the sheet name (so the macro knows where to put each files information). I am getting a run time error (424) though and can not figure out what it is that I need to define to make this process work. I am still quite new to VBA and have pieced this together from other codes which performed bits of the process that I am looking to do. I would welcome any advice on this please! Thanks. Liz. (Code is set out below): '32-bit API declarations (BT) Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Sub Commissioner() 'Switch off screen flashing Application.ScreenUpdating = False 'Turn off auto calculation With Application .Calculation = xlManual .MaxChange = 0.001 End With ActiveWorkbook.PrecisionAsDisplayed = False 'Request the user to select the folder containing the latest commissioner data Msg = "Select the folder containing the latest COMMISSIONER data" DDirectory = GetDirectory(Msg) If DDirectory = "" Then Exit Sub If Right(DDirectory, 1) < "\" Then DDirectory = DDirectory & "\" a = MsgBox(Prompt:=DDirectory, Buttons:=vbOKOnly) 'Open each text file and save it as an excel file ChDir DDirectory Set fso = CreateObject("Scripting.FileSystemObject").GetFold er(DDirectory) For Each file In fso.Files If file.Type = "Text Document" Then With file Workbooks.OpenText Filename:=file.Name _ , Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _ Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _ Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _ Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), _ Array(16, 1), Array(17, 1), Array(18, 1)), TrailingMinusNumbers:=True ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Name & ".xls" _ , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False ActiveWorkbook.Close End With End If Next Set fso = Nothing 'Unhide all worksheets Windows("Cancer monitoring (Commissioner).xls").Activate Sheets("6.1 ReportDownload").Visible = True Sheets("6.2 ReportDownload").Visible = True Sheets("7.1 ReportDownload").Visible = True Sheets("7.2 ReportDownload").Visible = True Sheets("7.7 ReportDownload").Visible = True Sheets("7.8 ReportDownload").Visible = True Sheets("8.1 ReportDownload").Visible = True Sheets("8.2 ReportDownload").Visible = True Sheets("8.7 ReportDownload").Visible = True Sheets("9.1 ReportDownload").Visible = True Sheets("9.2 ReportDownload").Visible = True Sheets("10.1 ReportDownload").Visible = True Sheets("10.2 ReportDownload").Visible = True 'Open each Excel file and copy it into the model Dim strWSName As String Dim ws As Worksheet done = False Windows("Cancer monitoring (Commissioner).xls").Activate For Each ws In ActiveWorkbook.Worksheets If Left(ws.Name, 3) = Left(wbdatafile.Name, 3) Then wbdatafile.Open Range("A2").Select Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select Selection.Copy ThisWorkbook.Activate strWSName = wbdatafile.Name If SheetExists = True Then Worksheets(strWSName).Activate Range("B65536").End(xlUp).Offset(1, -1).Select ActiveSheet.Paste Range("B65536").End(xlUp).Offset(1, -1).Select wbdatafile.Activate ActiveWorkbook.Close done = True End If End If Exit For Next 'Rehide all worksheets Sheets("6.1 ReportDownload").Visible = False Sheets("6.2 ReportDownload").Visible = False Sheets("7.1 ReportDownload").Visible = False Sheets("7.2 ReportDownload").Visible = False Sheets("7.7 ReportDownload").Visible = False Sheets("7.8 ReportDownload").Visible = False Sheets("8.1 ReportDownload").Visible = False Sheets("8.2 ReportDownload").Visible = False Sheets("8.7 ReportDownload").Visible = False Sheets("9.1 ReportDownload").Visible = False Sheets("9.2 ReportDownload").Visible = False Sheets("10.1 ReportDownload").Visible = False Sheets("10.2 ReportDownload").Visible = False 'Switch on auto calculation With Application .Calculation = xlAutomatic .MaxChange = 0.001 End With ActiveWorkbook.PrecisionAsDisplayed = False 'Switch on screen flashing Application.ScreenUpdating = True End Sub 'More BT declarations Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer ' Root folder = Desktop bInfo.pidlRoot = 0& ' Title in the dialog If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If ' Type of directory to return bInfo.ulFlags = &H1 ' Display the dialog x = SHBrowseForFolder(bInfo) ' Parse the result path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Else GetDirectory = "" End If End Function |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Looping Macro - Run Time Error
Hi.
Thanks for this. I think that you might be right, I dont seem to have defined it anywhere! I assume that I need to define it in the bit of the code with the fso.files reference - do I need to do it as Dim or Set?? Also, you mentioned about not closing, does this mean the files that were created in the fso.files bit (as there will be quite a lot of them open at one time otherwise) or are you referring to the loop??? Thanks. "JLatham" wrote: Maybe I'm missing it by trying to read the code in your post, but I don't see anywhere that you've set wbdatafile to any particular workbook. If you want it to be the same as the workbook you opened back in the For Each file in fso.Files loop, then you need to set the reference to it there, and wait until you are done with it later to close it, instead of closing it in that loop. Error 424 is "Object Required" error and I'm betting it's looking for the wbdatafile object so it can get the .Name property from it. Since it doesn't seem to exist yet, this is an impossible task. "BoRed79" wrote: Dear All. I have managed to piece together a complex code to perform a series of actions for me. The macro allows the user to select the folder containing the most up to date data, it then open each of the text files in that folder and converts them to excel files. Then I am trying to get it to copy and paste the data in each of those files onto the relevant sheet of the master workbook. I am trying to do this by matching the beginning of the file name and the beginning of the sheet name (so the macro knows where to put each files information). I am getting a run time error (424) though and can not figure out what it is that I need to define to make this process work. I am still quite new to VBA and have pieced this together from other codes which performed bits of the process that I am looking to do. I would welcome any advice on this please! Thanks. Liz. (Code is set out below): '32-bit API declarations (BT) Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Sub Commissioner() 'Switch off screen flashing Application.ScreenUpdating = False 'Turn off auto calculation With Application .Calculation = xlManual .MaxChange = 0.001 End With ActiveWorkbook.PrecisionAsDisplayed = False 'Request the user to select the folder containing the latest commissioner data Msg = "Select the folder containing the latest COMMISSIONER data" DDirectory = GetDirectory(Msg) If DDirectory = "" Then Exit Sub If Right(DDirectory, 1) < "\" Then DDirectory = DDirectory & "\" a = MsgBox(Prompt:=DDirectory, Buttons:=vbOKOnly) 'Open each text file and save it as an excel file ChDir DDirectory Set fso = CreateObject("Scripting.FileSystemObject").GetFold er(DDirectory) For Each file In fso.Files If file.Type = "Text Document" Then With file Workbooks.OpenText Filename:=file.Name _ , Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _ xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _ Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _ Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _ Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), _ Array(16, 1), Array(17, 1), Array(18, 1)), TrailingMinusNumbers:=True ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Name & ".xls" _ , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False ActiveWorkbook.Close End With End If Next Set fso = Nothing 'Unhide all worksheets Windows("Cancer monitoring (Commissioner).xls").Activate Sheets("6.1 ReportDownload").Visible = True Sheets("6.2 ReportDownload").Visible = True Sheets("7.1 ReportDownload").Visible = True Sheets("7.2 ReportDownload").Visible = True Sheets("7.7 ReportDownload").Visible = True Sheets("7.8 ReportDownload").Visible = True Sheets("8.1 ReportDownload").Visible = True Sheets("8.2 ReportDownload").Visible = True Sheets("8.7 ReportDownload").Visible = True Sheets("9.1 ReportDownload").Visible = True Sheets("9.2 ReportDownload").Visible = True Sheets("10.1 ReportDownload").Visible = True Sheets("10.2 ReportDownload").Visible = True 'Open each Excel file and copy it into the model Dim strWSName As String Dim ws As Worksheet done = False Windows("Cancer monitoring (Commissioner).xls").Activate For Each ws In ActiveWorkbook.Worksheets If Left(ws.Name, 3) = Left(wbdatafile.Name, 3) Then wbdatafile.Open Range("A2").Select Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select Selection.Copy ThisWorkbook.Activate strWSName = wbdatafile.Name If SheetExists = True Then Worksheets(strWSName).Activate Range("B65536").End(xlUp).Offset(1, -1).Select ActiveSheet.Paste Range("B65536").End(xlUp).Offset(1, -1).Select wbdatafile.Activate ActiveWorkbook.Close done = True End If End If Exit For Next 'Rehide all worksheets Sheets("6.1 ReportDownload").Visible = False Sheets("6.2 ReportDownload").Visible = False Sheets("7.1 ReportDownload").Visible = False Sheets("7.2 ReportDownload").Visible = False Sheets("7.7 ReportDownload").Visible = False Sheets("7.8 ReportDownload").Visible = False Sheets("8.1 ReportDownload").Visible = False Sheets("8.2 ReportDownload").Visible = False Sheets("8.7 ReportDownload").Visible = False Sheets("9.1 ReportDownload").Visible = False Sheets("9.2 ReportDownload").Visible = False Sheets("10.1 ReportDownload").Visible = False Sheets("10.2 ReportDownload").Visible = False 'Switch on auto calculation With Application .Calculation = xlAutomatic .MaxChange = 0.001 End With ActiveWorkbook.PrecisionAsDisplayed = False 'Switch on screen flashing Application.ScreenUpdating = True End Sub 'More BT declarations Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer ' Root folder = Desktop bInfo.pidlRoot = 0& ' Title in the dialog If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If ' Type of directory to return bInfo.ulFlags = &H1 ' Display the dialog x = SHBrowseForFolder(bInfo) ' Parse the result path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Else GetDirectory = "" End If End Function |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|