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.
I am expecting something like...WB_TB_Folder1_Result, WB_TB_Folder2_Result and so on.
Folder Structure:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Root Folder[/TD]
[/TR]
[TR]
[TD]
[/TR]
[TR]
[TD]
[/TR]
[TR]
[TD]
[/TR]
[TR]
[TD]
[/TR]
[TR]
[TD]
[/TR]
[TR]
[TD]
[/TR]
[TR]
[TD]
[/TR]
[TR]
[TD]
[/TR]
[TR]
[TD]
[/TR]
</tbody>[/TABLE]
My Code (5 Procedures)
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:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Root Folder[/TD]
[/TR]
[TR]
[TD]
Folder1
[/TD][/TR]
[TR]
[TD]
xls1
[/TD][/TR]
[TR]
[TD]
xls2
[/TD][/TR]
[TR]
[TD]
Folder2
[/TD][/TR]
[TR]
[TD]
xls1
[/TD][/TR]
[TR]
[TD]
xls2
[/TD][/TR]
[TR]
[TD]
Folder3
[/TD][/TR]
[TR]
[TD]
xls1
[/TD][/TR]
[TR]
[TD]
xls2
[/TD][/TR]
</tbody>[/TABLE]
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
Last edited: