Macro for folder Name reference

Chandresh

Board Regular
Joined
Jul 21, 2009
Messages
123
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
 

Some videos you may like

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Re: Macro for forder Name reference

Try this

Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,118,790
Messages
5,574,308
Members
412,586
Latest member
Medhum
Top