RedstoneIT
asked on
Excel script help. Getting files in one folder
The code I have listed below works perfectly except for one detail and I cant see why it is failing. It should pick all excel files from the chosen folder and all folders below it and combine them. The code WILL combine workbooks that are in sub-directories under the chosen file path, but it ignores workbooks in the chosen folder.
I need this code to be used either way. Some of the data it is pulling may or may not be in a sub folder.
Any suggestions on whats wrong and how to fix it ?
' Phase 1- Getting it to combine files
' Code provided by andrewssd3 at https://www.experts-exchange.com
' Phase 2 - Give the option to provide a starting folder location
' Code provided By wobbled at https://www.experts-exchange.com
' Phase 3 - Get the code to grab both workbooks in sub folders, but also the primary folder
Option Explicit
Private mwbkMaster As Excel.Workbook ' this totals workbook
Private mrngEQOut As Excel.Range ' next available cell for totals for EQ
Private mrngLabOut As Excel.Range ' next available cell for totals for Labor
Private mobjFSO As Object 'object 'Scripting.FileSystemObjec t
Public Sub ImportAll()
Dim shtEQTot As Excel.Worksheet
Dim shtLabTot As Excel.Worksheet
Dim fldMaster As Object 'Scripting.Folder
Dim fldSub As Object 'Scripting.Folder
Dim filData As Object 'Scripting.File
'Const cstrDataLoc As String = "G:\Database work for Chad\Time" ' starting location of search
Dim strFolder As String
strFolder = GetFolder("")
Set mwbkMaster = ThisWorkbook
' get the EQ totals sheet and find the first available row
Set shtEQTot = mwbkMaster.Worksheets("EQ Totals")
Set mrngEQOut = shtEQTot.UsedRange
Set mrngEQOut = mrngEQOut.Offset(mrngEQOut .Rows.Coun t, 1).Resize(1, 1)
' get the Labor totals sheet and find the first available row
Set shtLabTot = mwbkMaster.Worksheets("Lab or Totals")
Set mrngLabOut = shtLabTot.UsedRange
Set mrngLabOut = mrngLabOut.Offset(mrngLabO ut.Rows.Co unt, 1).Resize(1, 1)
' create the file system object
Set mobjFSO = CreateObject("Scripting.Fi leSystemOb ject")
' find the master folder
Set fldMaster = mobjFSO.GetFolder(strFolde r)
' loop through all the sub folders
For Each fldSub In fldMaster.SubFolders
' loop through all the files (should be only one?)
For Each filData In fldSub.Files
' check it's some sort of Excel file and process it
If LCase$(mobjFSO.GetExtensio nName(filD ata.Name)) Like "xls*" Then
Call ProcessFile(filData.Path)
End If
Next filData
Next fldSub
Set mrngEQOut = Nothing
Set mrngLabOut = Nothing
Set mobjFSO = Nothing
MsgBox "Completed"
End Sub
Private Sub ProcessFile(ByVal strPath As String)
' called once for each workbook found
Dim wbkIndiv As Excel.Workbook
Dim wksCurrIn As Excel.Worksheet
Dim rngIn As Excel.Range
Dim strCaption As String ' the name of the current input workbook
Dim aData As Variant
strCaption = mobjFSO.GetBaseName(strPat h)
' open the data workbook
Set wbkIndiv = Application.Workbooks.Open (Filename: =strPath, _
UpdateLinks:=False, ReadOnly:=True, addtomru:=False)
' get the first sheet
Set wksCurrIn = wbkIndiv.Worksheets("EQ Totals")
' get all data for this sheet into an array
Set rngIn = wksCurrIn.UsedRange
aData = rngIn.Value
' prepare the output range by making it the right size to receive the data
Set mrngEQOut = mrngEQOut.Resize(rngIn.Row s.Count, rngIn.Columns.Count)
' put in the values from the input sheet
mrngEQOut.Value = aData
' put in the label identifying this row
mrngEQOut.Offset(0, -1).Resize(mrngEQOut.Rows. Count, 1).Value = strCaption
' get the next sheet (NB this is the same as the previous sheet - left separate
' in case something needs to change at a later point for one sheet
Set wksCurrIn = wbkIndiv.Worksheets("Labor Totals")
' get all data for this sheet into an array
Set rngIn = wksCurrIn.UsedRange
aData = rngIn.Value
' prepare the output range by making it the right size to receive the data
Set mrngLabOut = mrngLabOut.Resize(rngIn.Ro ws.Count, rngIn.Columns.Count)
' put in the values from the input sheet
mrngLabOut.Value = aData
' put in the label identifying this row
mrngLabOut.Offset(0, -1).Resize(mrngLabOut.Rows .Count, 1).Value = strCaption
'move the output ranges on
Set mrngEQOut = mrngEQOut.Offset(mrngEQOut .Rows.Coun t, 0)
Set mrngLabOut = mrngLabOut.Offset(mrngLabO ut.Rows.Co unt, 0)
wbkIndiv.Saved = True
' close the data workbook
Application.DisplayAlerts = False
wbkIndiv.Close xlDoNotSaveChanges
Application.DisplayAlerts = True
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(mso FileDialog FolderPick er)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
I need this code to be used either way. Some of the data it is pulling may or may not be in a sub folder.
Any suggestions on whats wrong and how to fix it ?
' Phase 1- Getting it to combine files
' Code provided by andrewssd3 at https://www.experts-exchange.com
' Phase 2 - Give the option to provide a starting folder location
' Code provided By wobbled at https://www.experts-exchange.com
' Phase 3 - Get the code to grab both workbooks in sub folders, but also the primary folder
Option Explicit
Private mwbkMaster As Excel.Workbook ' this totals workbook
Private mrngEQOut As Excel.Range ' next available cell for totals for EQ
Private mrngLabOut As Excel.Range ' next available cell for totals for Labor
Private mobjFSO As Object 'object 'Scripting.FileSystemObjec
Public Sub ImportAll()
Dim shtEQTot As Excel.Worksheet
Dim shtLabTot As Excel.Worksheet
Dim fldMaster As Object 'Scripting.Folder
Dim fldSub As Object 'Scripting.Folder
Dim filData As Object 'Scripting.File
'Const cstrDataLoc As String = "G:\Database work for Chad\Time" ' starting location of search
Dim strFolder As String
strFolder = GetFolder("")
Set mwbkMaster = ThisWorkbook
' get the EQ totals sheet and find the first available row
Set shtEQTot = mwbkMaster.Worksheets("EQ Totals")
Set mrngEQOut = shtEQTot.UsedRange
Set mrngEQOut = mrngEQOut.Offset(mrngEQOut
' get the Labor totals sheet and find the first available row
Set shtLabTot = mwbkMaster.Worksheets("Lab
Set mrngLabOut = shtLabTot.UsedRange
Set mrngLabOut = mrngLabOut.Offset(mrngLabO
' create the file system object
Set mobjFSO = CreateObject("Scripting.Fi
' find the master folder
Set fldMaster = mobjFSO.GetFolder(strFolde
' loop through all the sub folders
For Each fldSub In fldMaster.SubFolders
' loop through all the files (should be only one?)
For Each filData In fldSub.Files
' check it's some sort of Excel file and process it
If LCase$(mobjFSO.GetExtensio
Call ProcessFile(filData.Path)
End If
Next filData
Next fldSub
Set mrngEQOut = Nothing
Set mrngLabOut = Nothing
Set mobjFSO = Nothing
MsgBox "Completed"
End Sub
Private Sub ProcessFile(ByVal strPath As String)
' called once for each workbook found
Dim wbkIndiv As Excel.Workbook
Dim wksCurrIn As Excel.Worksheet
Dim rngIn As Excel.Range
Dim strCaption As String ' the name of the current input workbook
Dim aData As Variant
strCaption = mobjFSO.GetBaseName(strPat
' open the data workbook
Set wbkIndiv = Application.Workbooks.Open
UpdateLinks:=False, ReadOnly:=True, addtomru:=False)
' get the first sheet
Set wksCurrIn = wbkIndiv.Worksheets("EQ Totals")
' get all data for this sheet into an array
Set rngIn = wksCurrIn.UsedRange
aData = rngIn.Value
' prepare the output range by making it the right size to receive the data
Set mrngEQOut = mrngEQOut.Resize(rngIn.Row
' put in the values from the input sheet
mrngEQOut.Value = aData
' put in the label identifying this row
mrngEQOut.Offset(0, -1).Resize(mrngEQOut.Rows.
' get the next sheet (NB this is the same as the previous sheet - left separate
' in case something needs to change at a later point for one sheet
Set wksCurrIn = wbkIndiv.Worksheets("Labor
' get all data for this sheet into an array
Set rngIn = wksCurrIn.UsedRange
aData = rngIn.Value
' prepare the output range by making it the right size to receive the data
Set mrngLabOut = mrngLabOut.Resize(rngIn.Ro
' put in the values from the input sheet
mrngLabOut.Value = aData
' put in the label identifying this row
mrngLabOut.Offset(0, -1).Resize(mrngLabOut.Rows
'move the output ranges on
Set mrngEQOut = mrngEQOut.Offset(mrngEQOut
Set mrngLabOut = mrngLabOut.Offset(mrngLabO
wbkIndiv.Saved = True
' close the data workbook
Application.DisplayAlerts = False
wbkIndiv.Close xlDoNotSaveChanges
Application.DisplayAlerts = True
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(mso
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
found it. its a variant
Thank you.
Thank you.
ASKER