I'm doing an office project where i need to create a macro.
I have a folder with 30 subfolders each named after our branches. For example- Chicago branch, New York branch etc. Each subfolder contains a number of workbooks and each workbook has a number of worksheet full of data.
I made a macro to extract a number of cells from the worksheet called "Menu" and one cell from the worksheet called "score" and paste it in a new workbook.
I have researched online and made two separate macros to get the data from the two seperate worksheets. But it only works if I select all the files I want inside a subfolder.
I also found some code to access folders inside subfolders but I couldn't compile it with my current code. In addition, I couldn't join the two macros I made, so it'd require only one button instead of two.
Now, I need a macro which will ask me to select a folder and go to the subfolders and folders inside the subfolders by itself and consolidate the data in a new workbook BUT in separate worksheets based on the Subfolders( the branch named ones, not the folders inside subfolders.
The data extracted from workbooks in the folders inside subfolders need to be in the worksheet named after the subfolder.) The idea is to have to press the command button once to get all the data extracted from that folder and subfolders inside at once as its too hectic to use my code 30 times for 30 subfolders to get data of 30 branches.
"Macro for extracting data from the worksheet MENU of each workbook"
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
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 Sub
"Macro for extracting data from the worksheet SCORE of each workbook"
Private Sub CommandButton2_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 = "score" '<---- Change
Set Rng = Range("f65") '<---- 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 = 6
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("g2").Select
ActiveCell.FormulaR1C1 = "Score"
Range("g2").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
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End If
For Each SummWks In ThisWorkbook.Sheets
Set aCell = SummWks.Rows(2).Find(what:="Score", 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 = "0%"
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 = "0%"
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 Sub
Aucun commentaire:
Enregistrer un commentaire