Hello!
I am looking for a way to add the code that goes inside sub folders in an existing code that i wrote for consolidating data from multiple worksheet.
I have tried several times with several different codes but couldn't add the code for looking in sub folders to my codes for consolidating data. Every time i try to add it the code shows error and doesn't run smoothly.
If anyone can add the vba code for sub folders to my existing macro for consolidating data and post the final code here that'd be really helpful. Thanks in advance
My code for consolidating data
The code to access sub folders (Provided by Dave):
I am looking for a way to add the code that goes inside sub folders in an existing code that i wrote for consolidating data from multiple worksheet.
I have tried several times with several different codes but couldn't add the code for looking in sub folders to my codes for consolidating data. Every time i try to add it the code shows error and doesn't run smoothly.
If anyone can add the vba code for sub folders to my existing macro for consolidating data and post the final code here that'd be really helpful. Thanks in advance
My code for consolidating data
Code:
Private Sub CommandButton1_Click()
Dim FileNameXls As Variant
Dim Summwks As Worksheet
Dim ColNum As Integer
Dim myCell As Range, Rng As Range
Dim RwNum As Long, FNum As Long, FinalSlash As Long
Dim ShName As String, PathStr As String
Dim SheetCheck As String, JustFileName As String
Dim JustFolder As String
Dim aCell As Range, bCell As Range
Dim lastRow As Long, i As Long
Dim ExitLoop As Boolean
ShName = "Menu" '<---- Change
Set Rng = Range("B9:b13") '<---- Change
'Select the files with GetOpenFilename
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*", _
MultiSelect:=True)
If IsArray(FileNameXls) = False Then
'do nothing
Else
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Add a new workbook with one sheet for the Summary
Set Summwks = Sheets("Sheet1")
'The links to the first workbook will start in row 2
RwNum = 2
For FNum = LBound(FileNameXls) To UBound(FileNameXls)
ColNum = 1
RwNum = RwNum + 1
FinalSlash = InStrRev(FileNameXls(FNum), "\")
JustFileName = Mid(FileNameXls(FNum), FinalSlash + 1)
JustFolder = Left(FileNameXls(FNum), FinalSlash - 1)
'build the formula string
JustFileName = WorksheetFunction.Substitute(JustFileName, "'", "''")
PathStr = "'" & JustFolder & "\[" & JustFileName & "]" & ShName & "'!"
On Error Resume Next
SheetCheck = ExecuteExcel4Macro(PathStr & Range("A1").Address(, , xlR1C1))
If Err.Number <> 0 Then
'If the sheet not exist in the workbook the row color will be Yellow.
Summwks.Cells(RwNum, 1).Resize(1, Rng.Cells.Count + 1) _
.Interior.Color = vbYellow
Else
For Each myCell In Rng.Cells
ColNum = ColNum + 1
Summwks.Cells(RwNum, ColNum).Formula = _
"=" & PathStr & myCell.Address
Next myCell
End If
On Error GoTo 0
Next FNum
' Use AutoFit to set the column width in the new workbook
Summwks.UsedRange.Columns.AutoFit
Range("b2").Select
ActiveCell.FormulaR1C1 = "Client Name"
Range("C2").Select
ActiveCell.FormulaR1C1 = "Occupation"
Range("D2").Select
ActiveCell.FormulaR1C1 = "Date"
Range("E2").Select
ActiveCell.FormulaR1C1 = "Insured Location"
Range("F2").Select
ActiveCell.FormulaR1C1 = "Serveyed by"
Range("B1").Select
ActiveCell.FormulaR1C1 = "=""Property Risk Scores Updated as at """
Rows("1:1").RowHeight = 27.75
Range("B1").Select
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("C1").Select
ActiveCell.FormulaR1C1 = "=TODAY()"
Range("c1").Select
With Selection.Font
.Name = "Calibri"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Range("b2:f2").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Font.Bold = True
Application.ScreenUpdating = True
MsgBox "The Summary is ready, save the file if you want to keep it"
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
For Each Summwks In ThisWorkbook.Sheets
Set aCell = Summwks.Rows(2).Find(what:="Date", LookIn:=xlValues, _
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
ExitLoop = False
If Not aCell Is Nothing Then
Set bCell = aCell
Summwks.Columns(aCell.Column).NumberFormat = "dd/mm/yyyy;@"
lastRow = Summwks.Range(Split(Summwks.Cells(, aCell.Column).Address, "$")(1) & _
Summwks.Rows.Count).End(xlUp).Row
For i = 2 To lastRow
With Summwks.Range(Split(Summwks.Cells(, aCell.Column).Address, "$")(1) & i)
.FormulaR1C1 = .Value
End With
Next i
Summwks.Columns(aCell.Column).AutoFit
Do While ExitLoop = False
Set aCell = Summwks.Rows(2).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
Summwks.Columns(aCell.Column).NumberFormat = "dd/mm/yyyy;@"
lastRow = Summwks.Range(Split(Summwks.Cells(, aCell.Column).Address, "$")(1) & _
Summwks.Rows.Count).End(xlUp).Row
For i = 2 To lastRow
Summwks.Range(Split(Summwks.Cells(, aCell.Column).Address, "$")(1) & i).FormulaR1C1 = _
Summwks.Range(Split(Summwks.Cells(, aCell.Column).Address, "$")(1) & i).Value
Next i
Else
ExitLoop = True
End If
Loop
End If
Next
End SubThe code to access sub folders (Provided by Dave):
Code:
Dim oSheet
Dim oFso : Set oFso = CreateObject("Scripting.FileSystemObject")
Dim oFolder : Set oFolder = oFso.GetFolder("Path to Desktop Branch Data folder in here")
Dim oSubFolder, oBranchWorkbook, oWorksheet, iSheet
iSheet = 1
For Each oSubFolder in oFolder.SubFolders
Debug.Print "Looking inside " & oSubFolder.Name
' Set the sheet to copy to (1 on the first, 2 on the second etc)
' this would be better if the sheets were named for each branch folder
' as then instead of iSheet you could use oSubFolder.Name and it wouldn't matter if things were out of order for some reason...
Set oSheet = ThisWorkbook.Worksheets(iSheet)
For Each oFile in oSubFolder.Files
If Right(oFile.Name,3) = "xls" or Right(oFile.Name, 4) = "xlsx" Then
Set oBranchWorkbook = Workbooks.Open(oSubFolder.Path & oFile.Name)
' Now you have the Info.xls from whichever branch folder we are in open
Set oWorksheet = oBranchWorkbook.Worksheets("Menu")
' Extract whatever you need from Menu to the current workbook, e.g.
oSheet.Range("A1").Value = oWorksheet.Range("B1").Value
' Once you complete the Menu extract, change oWorksheet to point at Score
Set oWorksheet = oBranchWorkbook.Worksheets("Score")
' Extract whatever you need from Score to the current workbook, e.g.
oSheet.Range("A1").Value = oWorksheet.Range("B1").Value
'Once you have completed all the extracts you need, close the branch workbook
oBranchWorkbook.Close
End If
Next
iSheet = iSheet + 1 ' increment sheet counter
Next ' Move onto next subfolder and repeat the process...
