VBA - Help adding filename to macro that pulls data from workbook

[whazzzzzupp17]

Hello, trying to modify my VBA script to include the filename within the range of data that I'm copying from multiple workbooks to my main workbook.

I'm currently pasting the data in column B, but would like column A to include the workbook name within each cell.

Sub CopyFolderFiles()
    
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    xSheetName = "Project"
    xRgStr = "BJ9:CE100"
    
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    
        With xFileDlg
            If .Show = -1 Then
                xSelItem = .SelectedItems.Item(1)
                Set xWorkBook = ThisWorkbook
                Set xSheet = xWorkBook.Sheets("New Sheet")
                
                If xSheet Is Nothing Then
                    xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                    Set xSheet = xWorkBook.Sheets("New Sheet")
                End If

                xFileName = Dir(xSelItem & "\*.xlsm", vbNormal)
                
                If xFileName = "" Then Exit Sub
                
                Do Until xFileName = ""
                   Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                    Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                    xRg.Copy xSheet.Range("B65536").End(xlUp).Offset(1, 0)
                    
                    xFileName = Dir()
                    xBook.Close
                    
                Loop
            End If
        End With
    
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

 

[DanteAmor]

Try this

Sub CopyFolderFiles()
  Dim xRg As Range
  Dim xSelItem As Variant
  Dim xFileDlg As FileDialog
  Dim xFileName, xSheetName, xRgStr As String
  Dim xBook As Workbook, xWorkBook As Workbook
  Dim xSheet As Worksheet
  Dim lr1 As Long, lr2 As Long
  
  On Error Resume Next
  Application.DisplayAlerts = False
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  
  xSheetName = "Project"
  xRgStr = "BJ9:CE100"
  
  Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
  
  With xFileDlg
      If .Show = -1 Then
          xSelItem = .SelectedItems.Item(1)
          Set xWorkBook = ThisWorkbook
          Set xSheet = xWorkBook.Sheets("New Sheet")
          
          If xSheet Is Nothing Then
              xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
              Set xSheet = xWorkBook.Sheets("New Sheet")
          End If

          xFileName = Dir(xSelItem & "\*.xlsm", vbNormal)
          Do While xFileName <> ""
            Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
            Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
            lr1 = xSheet.Range("B65536").End(xlUp).Row + 1
            xRg.Copy xSheet.Range("B" & lr1)
            lr2 = xSheet.Range("B65536").End(xlUp).Row
            xSheet.Range("A" & lr1 & ":A" & lr2).Value = xBook.Name
            xBook.Close False
            xFileName = Dir()
          Loop
      End If
  End With
  
  Application.DisplayAlerts = True
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

 

[whazzzzzupp17]

Works perfectly! Thank you

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[whazzzzzupp17]

I'm glad to help you. Thanks for the feedback.

Hey I had one thing I'm trying to fix. How would I go about removing the file dialog box and inputting a fixed location so I don't have to search it each time.

 

[DanteAmor]

Try this

Sub CopyFolderFiles()
  Dim xBook As Workbook, xWorkBook As Workbook, xSheet As Worksheet
  Dim xFileName As Variant, xSheetName As String, xRgStr As String
  Dim xSelItem As String, xRg As Range, lr1 As Long, lr2 As Long
  
  On Error Resume Next
  Application.DisplayAlerts = False
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  
  xSheetName = "Project"
  xRgStr = "BJ9:CE100"
  xSelItem = "C:\trabajo\books\"
  Set xWorkBook = ThisWorkbook
  Set xSheet = xWorkBook.Sheets("New Sheet")
  If xSheet Is Nothing Then
    xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
    Set xSheet = xWorkBook.Sheets("New Sheet")
  End If

  xFileName = Dir(xSelItem & "\*.xlsm", vbNormal)
  Do While xFileName <> ""
    Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
    Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
    lr1 = xSheet.Range("B65536").End(xlUp).Row + 1
    xRg.Copy xSheet.Range("B" & lr1)
    lr2 = xSheet.Range("B65536").End(xlUp).Row
    xSheet.Range("A" & lr1 & ":A" & lr2).Value = xBook.Name
    xBook.Close False
    xFileName = Dir()
  Loop
  
  Application.DisplayAlerts = True
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

 

[CamVilla]

Can I instead of copying the data from the different workbooks by row, place by column (identifying the last empty cell)?