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
|