B
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
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