Sub Prepare_Modules() Dim FSO As Scripting.FileSystemObject
Dim FF As Scripting.Folder
Dim ss As String
Set FSO = New Scripting.FileSystemObject
ss = GetFolder(msoFileDialogFolderPicker)
If Not ss = "" Then
Set FF = FSO.GetFolder(ss)
Application.ScreenUpdating = False
DoOneFolder FF
Application.ScreenUpdating = True
MsgBox "Completed"
Else
MsgBox "No Folder Selected"
End If
End Sub
Sub DoOneFolder(FF As Scripting.Folder)
Dim F As Scripting.File
Dim SubF As Scripting.Folder
Dim WB As Workbook
Dim r, c, i, x, n As Long
Dim BM, PR, CR, AR, AED As Range
For Each F In FF.Files
If InStr(F.Type, "Excel") > 0 Then
If InStr(F.Name, "Module") > 0 Then
Workbooks.Open F.Path
Set WB = ActiveWorkbook
wbName = ActiveWorkbook.Name
Sheets("Expense Data").Select
r = ActiveSheet.Range("C" & Rows.Count).End(xlUp).Row
c = ActiveSheet.Cells(5, Columns.Count).End(xlToLeft).Column
For i = 7 To c
If Not Cells(r, i) = 0 Then
For x = 7 To r - 1
If Not Cells(x, i) = 0 Then
Set BM = ActiveSheet.Range("B2")
Set PR = ActiveSheet.Range("B" & x & ":" & "F" & x)
Set CR = ActiveSheet.Cells(6, i)
Set NR = ActiveSheet.Cells(5, i)
Set AR = ActiveSheet.Cells(x, i)
Set AED = Sheets("Cost Center Breakup").Range("D2")
Windows(ThisWorkbook.Name).Activate
Sheets("Modules").Select
n = Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
Range("A" & n) = FF.Name
Range("B" & n) = BM.Value
Range("H" & n) = CR.Value
Range("I" & n) = NR.Value
Range("J" & n) = AR.Value
Range("K" & n) = AED.Value
PR.Copy
Range("C" & n).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Windows(wbName).Activate
Set BM = Nothing
Set PR = Nothing
Set CR = Nothing
Set NR = Nothing
Set AR = Nothing
Set AED = Nothing
End If
Next
End If
Next
Windows(wbName).Activate
WB.Close False
End If
End If
Next F
For Each SubF In FF.SubFolders
DoOneFolder SubF
Next SubF
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select Month Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
