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 |
Thread Tools | Search this Thread |
Display Modes | |
|
|