Looping Macro - Run Time Error

[BoRed79]

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").GetFolder(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

 

[BoRed79]

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

 

[Rick Rothstein]

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?

 

[JLatham]

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]

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.