How to Loop through all the folders and add dynamic sheet name

[petes]

Hi Guys -

I am calling a dialog box from the UI, wherein the user selects the folder and macro will run accordingly by taking the excel files from that particular folder which the user has selected (Code mentioned below).

I need the following 2 things to be implemented:

1) Once the user selects the root folder, the macro should run for all the folders present under the root. Note: The template of all the files present under each folder are same, except the name will be different. Hence, this macro holds good for all the files present in different folders. I just need to alter this existing macro, so that the same macro will loop until the last folder is reached.

2) The sheet naming convention should be dynamic as per the folder name. Currently I have hard-coded the sheet name because of single folder.

Worksheets("WB_TB_RESULT").Select.

I am expecting something like...WB_TB_Folder1_Result, WB_TB_Folder2_Result and so on.

Folder Structure:

Root Folder

Folder1​

xls1​

xls2​

Folder2​

xls1​

xls2​

Folder3​

xls1​

xls2​

<tbody>
</tbody>

My Code (5 Procedures)

Sub WBTR_GetSourceTargetData()

Dim vFile As Variant
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet
Dim fPath As String
Dim fldr As FileDialog
Dim sItem As String

Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = Worksheets("Source")

'----------------------Open file

fn = Dir(myPath & "*Trial*.vis")
Set wbCopyFrom = Workbooks.Open(myPath & fn)

'---------------------------Add Validation

If Range("A1").Value = "" Or Range("D1").Value <> "" Then
ActiveWorkbook.Close False
Worksheets("Launch").Select
Range("A1").Value = "TBSRCLayout"
Exit Sub
End If

'-------------------------Clear Exisiting Data

wsCopyTo.Activate
Worksheets("Source").Select
ActiveSheet.AutoFilterMode = False
Cells.Select
Selection.ClearContents
Selection.ClearFormats

Worksheets("Target").Select
ActiveSheet.AutoFilterMode = False
Cells.Select
Selection.ClearContents
Selection.ClearFormats

'-----------------------------Copy Range

wbCopyFrom.Activate
Set wsCopyFrom = wbCopyFrom.Worksheets(1)

Application.DisplayAlerts = False
wsCopyFrom.Cells.Select
Selection.Copy
wsCopyTo.Range("A1").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'Close file that was opened
wbCopyFrom.Close SaveChanges:=False
Application.CutCopyMode = False
Application.DisplayAlerts = False

Worksheets("Launch").Select

'**TGT portion***************

Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = Worksheets("Target")

'----------------------------File will be automatically opened

fn = Dir(myPath & "*Trial*.xlsx")
Set wbCopyFrom = Workbooks.Open(myPath & fn)

On Error Resume Next
ActiveWorkbook.Worksheets("table1").Select

'---------------------------Add Validation

If Range("A1").Value <> "DetailAccount" Or Range("E1").Value <> "BeginningBalance" Then
ActiveWorkbook.Close False
Worksheets("Launch").Select
Range("A2").Value = "TBTGTLayout"
Exit Sub
End If

'---------------------------Clear Exisiting Data

wsCopyTo.Activate
Worksheets("Target").Select
ActiveSheet.AutoFilterMode = False
Cells.Select
Selection.ClearContents
Selection.ClearFormats

'-----------------------------Copy Range

wbCopyFrom.Activate
Set wsCopyFrom = wbCopyFrom.Worksheets(1)

Application.DisplayAlerts = False
Cells.Select
Selection.Copy
wsCopyTo.Range("A1").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'Close file that was opened
wbCopyFrom.Close SaveChanges:=False
Application.CutCopyMode = False
Application.DisplayAlerts = False

Worksheets("Launch").Select

End Sub

Sub WBTR_PutFormula()

'------------------Insert Header Row

Worksheets("Source").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown

'------------------Add Formula in Source Sheet

ActiveSheet.Range("H2").Formula = "=IF(ISERR(LEFT(C2,1)*1),"""",IF(LEN(C2)<>30,"""",IF(MID(C2,4,1)=""T"",MID(C2,13,4),MID(C2,11,4))))"

'Fill Formula by Referencing C
Dim LastRow1 As Long
LastRow1 = Cells(Rows.Count, "C").End(xlUp).Row
Range("H2").AutoFill Destination:=Range("H2:H" & LastRow1)

'To Get Unique Values
Dim d As Object, c As Variant, i As Long, lr As Long
Set d = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("H2:H" & lr)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
Range("I2").Resize(d.Count) = Application.Transpose(d.keys)

'Add 2nd Part of Formula
ActiveSheet.Range("J2").Formula = "=IF(LEN(I2)<>4,"""",SUMIF(H:H,I2,G:G))"
ActiveSheet.Range("K2").Formula = "=IF(LEN(I2)<>4,"""",VLOOKUP(TEXT(I2,0),Target!A:E,5,0)+VLOOKUP(TEXT(I2,0),Target!A:F,6,0))"
ActiveSheet.Range("L2").Formula = "=IF(LEN(I2)<>4,"""",IF((J2-K2)>0.99,""FALSE"",IF((J2-K2)>0,""TRUE"",IF(J2=K2,""TRUE"",""FALSE""))))"

'Fill Formula by Referencing I
Dim LastRow2 As Long
LastRow2 = Cells(Rows.Count, "I").End(xlUp).Row
Range("J2:L2").AutoFill Destination:=Range("J2:L" & LastRow2)

End Sub

Sub WBTR_FormulaValues()

Worksheets("Source").Select
Range("H2:L2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

End Sub

Sub WBTR_FormatData()

'----------Add Header in Source Sheet

Worksheets("Source").Select
Range("A1").Value = "Sl No"
Range("B1").Value = "Sequence"
Range("C1").Value = "Account Number"
Range("D1").Value = "Account Name"
Range("E1").Value = "Amt1"
Range("F1").Value = "Amt2"
Range("G1").Value = "Amt3"
Range("H1").Value = "Extract Account"
Range("I1").Value = "Account Number"
Range("J1").Value = "ST Amt"
Range("K1").Value = "TT Amt"
Range("L1").Value = "Result"

'----------Format Data

Range("A1:L1").Select
Selection.Font.Bold = True

Range("H:H,I:I").Select
Selection.HorizontalAlignment = xlCenter

Range("A1:H1").Select
Selection.Interior.ThemeColor = xlThemeColorAccent3
Selection.Interior.TintAndShade = 0.599993896298105

Range("I1:L1").Select
Selection.Interior.ThemeColor = xlThemeColorAccent6
Selection.Interior.TintAndShade = 0.799981688894314

Cells.Select
Cells.EntireColumn.AutoFit

End Sub

Sub WBTR_ResultSheet()

Worksheets("WB_TB_RESULT").Select
ActiveSheet.AutoFilterMode = False
Cells.Select
Selection.ClearContents
Selection.ClearFormats

Worksheets("Source").Select
Columns("I:L").Select
Selection.Cut
Sheets("WB_TB_RESULT").Select
Range("A1").Select
ActiveSheet.Paste
Columns("A:D").EntireColumn.AutoFit
Range("A1").Select

End Sub