Include Filename to Each Row When Importing Multiple Files Data Into 1 Worksheet

[LocarAce]

Hi,

I have the below script working well which extracts the data of all the Excel files in a chosen folder and put into 1 single worksheet.
However, I also need the Filename (in Column A) to differentiate which data came from which file.

I am struggling my way around this.
Appreciate the help.

Sub ImportFiles()
' https://www.mrexcel.com/board/threads/vba-code-to-combine-multiple-workbooks-into-one-worksheet.1172117/

    Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String
    Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, FileName As String
    Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
    Dim FolderPath As String, fldr As FileDialog, Lr As Long, Lc As Long, Lr2 As Long
    
    On Error Resume Next
    
    Set xTWB = ThisWorkbook
    Set DestSheet = xTWB.ActiveSheet
    Debug.Print DestSheet.Name
    
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
        With fldr
            .Title = "Select a Folder"
            .AllowMultiSelect = False
            .InitialFileName = Application.DefaultFilePath
            If .Show <> -1 Then GoTo NextCode
            sItem = .SelectedItems(1)
        End With
    
NextCode:
        FolderName = sItem
        Set fldr = Nothing
        FolderPath = FolderName & "\"
   
    FileName = Dir(FolderPath & "[B]ThisIsTheSourceFile[/B]*")

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False

    Do While FileName <> ""
    Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
    xStrAWBName = ActiveWorkbook.Name

    Set Sh1 = ActiveWorkbook.Sheets("[B]Sheet1[/B]")
    xStrName = Sh1.Name

    For Each xWS In ActiveWorkbook.Sheets

    If xWS.Name = xStrName Then
        Lr = DestSheet.Range("B" & rows.Count).End(xlUp).row
        Lr2 = xWS.Range("B" & rows.Count).End(xlUp).row
        Lc = Cells(1, Columns.Count).End(xlToLeft).Column
        If Lr = 1 Then
            Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("B1")
        Else
            Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("B" & Lr + 1)
        End If
    End If

    Next xWS
    Workbooks(xStrAWBName).Close
    FileName = Dir()
    Loop

    'xTWB.Save

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic

End Sub

 

[RobP]

Hi, did I understand your code correctly ? (I'm assuming everytime you add row data, you can add the filename to it ?) by adding the below 2 lines into yours.

Rgds
Rob

If Lr = 1 Then
            DestSheet.Range("A1") = FileName
            Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("B1")
        Else
            DestSheet.Range("A" & Lr+1) = FileName
            Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("B" & Lr + 1)
        End If

 

[Alex Blakenburg]

I haven't been able to properly test this but see the below code works for you.
What is in red, is what I have added. The rest is just to show you where I think it should go.
Note: I suspect it will give you the full file name and path. If you want just the file name try swapping where I have Filename to ActiveWorkbook.Name
You may want to add the Sheet name to that as well.

everytime you add row data

@RobP - the code is copying all the rows each time for each worksheet in each file. It is not looping through the rows.

    For Each xWS In ActiveWorkbook.Sheets

    If xWS.Name = xStrName Then
        Lr = DestSheet.Range("B" & Rows.Count).End(xlUp).Row
        Lr2 = xWS.Range("B" & Rows.Count).End(xlUp).Row
        Lc = Cells(1, Columns.Count).End(xlToLeft).Column
        If Lr = 1 Then
            Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("B1")
        Else
            Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("B" & Lr + 1)
        End If
        With DestSheet
            .Range(.Cells(Lr + 1, "A"), .Cells(Rows.Count, "B").End(xlUp).Offset(0, -1)) = FileName
        End With
    End If

    Next xWS
    Workbooks(xStrAWBName).Close
    FileName = Dir()
    Loop

 

[dmt32]

Hi,
not fully tested but another update to your code you can try & see if does what you want

Sub ImportFiles()
 
    Dim xStrName    As String, FileName As String, FolderName As String
    Dim FolderPath  As String, sItem As String
    Dim xWS         As Worksheet, DestSheet As Worksheet
    Dim xTWB        As Workbook, xAWB As Workbook
    Dim Lr          As Long, Lc As Long, Lr2 As Long
    Dim fldr        As FileDialog
 
    On Error GoTo myerror
 
    Set xTWB = ThisWorkbook
    Set DestSheet = xTWB.ActiveSheet
    Debug.Print DestSheet.Name
 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        'cancel pressed
        If .Show <> -1 Then Exit Sub
        sItem = .SelectedItems(1)
    End With
 
    Set fldr = Nothing
 
NextCode:
    FolderName = sItem
    FolderPath = FolderName & "\"
 
    FileName = Dir(FolderPath & "ThisIsTheSourceFile*")
 
    EventsEnable False
 
    Do While FileName <> ""
        Set xAWB = Workbooks.Open(FileName:=FolderPath & FileName, UpdateLinks:=0, ReadOnly:=True)
    
        Set xWS = xAWB.Worksheets("Sheet1")
    
        Lr = DestSheet.Range("B" & DestSheet.Rows.Count).End(xlUp).Row
        Lr = Lr + IIf(Lr = 1, 0, 1)
    
        Lr2 = xWS.Range("B" & xWS.Rows.Count).End(xlUp).Row
        Lc = xWS.Cells(1, xWS.Columns.Count).End(xlToLeft).Column
    
    
        xWS.Cells(IIf(Lr = 1, 1, 2), 2).Resize(Lr2, Lc).Copy DestSheet.Cells(Lr, 2)
        'add file name to column A
        DestSheet.Cells(IIf(Lr = 1, 2, Lr), 1).Resize(Lr2 - 1, 1).Value = xAWB.Name
    
        xAWB.Close False
    
nextfile:
        FileName = Dir()
    Loop
 
myerror:
    If Err <> 0 Then
        If Not xAWB Is Nothing Then xAWB.Close False
        If Err.Number = 9 Then Resume nextfile Else MsgBox (Error(Err)), 48, "Error"
    End If
    EventsEnable True
End Sub

Sub EventsEnable(ByVal State As Boolean)
    With Application
        .ScreenUpdating = State
        .DisplayAlerts = State
        .EnableEvents = State
        .Calculation = IIf(State, xlCalculationAutomatic, xlCalculationManual)
    End With
End Sub

If I read your code correctly you are only copying from a Sheet named "Sheet1" in each file so I have changed code to only look for this sheet rather than looping all sheets in the file?

Dave