Macro for folder Name reference

[Chandresh]

HI,all ,

I am using following macro for extracting the data from sub folders my macro is working fine.

just need a help if macro can update the reference of folder in column "Z" from where the data is copied.

Ex : if data is copied from Folder no - 1 then my reference should be - 1 in column Z

Thanks in advance.



Sub TDS()
Dim fNAME As String: fNAME = "03-TDS.xls"
Dim fPATH As String: fPATH = "C:\Users\chandresh.choudhary\Desktop\test Merge"
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FLD As Object: Set FLD = FSO.GetFolder(fPATH)
Dim SubFLDRS As Object: Set SubFLDRS = FLD.SubFolders
Dim SubFLD As Object
Dim wbMain As Workbook: Set wbMain = ThisWorkbook
Dim wbData As Workbook
Dim ws As Worksheet
Dim LR As Long
For Each SubFLD In SubFLDRS
Set wbData = Workbooks.Open(fPATH & SubFLD.Name & "" & fNAME)

For Each ws In ActiveWorkbook.Worksheets
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A1:A" & LR).EntireRow.Copy
wbMain.Sheets(ws.Name).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Next ws

Application.CutCopyMode = False
wbData.Close False
Next SubFLD
Set wbMain = Nothing
End Sub

 

[DanteAmor]

Re: Macro for forder Name reference

Try this

Sub TDS()
    Dim fNAME As String: fNAME = "01.xlsx" '"03-TDS.xls"
    Dim fPATH As String: fPATH = "C:\trabajo\" '"C:\Users\chandresh.choudhary\Desktop\test Merge"
    Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim FLD As Object: Set FLD = FSO.GetFolder(fPATH)
    Dim SubFLDRS As Object: Set SubFLDRS = FLD.SubFolders
    Dim SubFLD As Object
    Dim wbMain As Workbook: Set wbMain = ThisWorkbook
    Dim wbData As Workbook
    Dim ws As Worksheet
    Dim LR As Long, lr2 As Long
    For Each SubFLD In SubFLDRS
        Set wbData = Workbooks.Open(fPATH & SubFLD.Name & "\" & fNAME)
        
        For Each ws In ActiveWorkbook.Worksheets
            LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
            ws.Range("A1:A" & LR).EntireRow.Copy
            lr2 = wbMain.Sheets(ws.Name).Range("A" & Rows.Count).End(xlUp).Offset(1).Row
            wbMain.Sheets(ws.Name).Range("A" & lr2).PasteSpecial xlPasteValues
            wbMain.Sheets(ws.Name).Range("Z" & lr2).Resize(LR).Value = SubFLD.Name
        Next ws
        
        Application.CutCopyMode = False
        wbData.Close False
    Next SubFLD
    Set wbMain = Nothing
End Sub

 

[Chandresh]

Re: Macro for forder Name reference

Thanks

 

[DanteAmor]

Re: Macro for forder Name reference

Thanks

You're welcome.