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

whazzzzzupp17

New Member
Joined
Jul 23, 2018
Messages
21
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.

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

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,622
Office Version
  1. 2007
Platform
  1. Windows
Try this

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

New Member
Joined
Jul 23, 2018
Messages
21

ADVERTISEMENT

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

Well-known Member
Joined
Dec 3, 2018
Messages
12,622
Office Version
  1. 2007
Platform
  1. Windows
Try this

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

New Member
Joined
Feb 8, 2021
Messages
21
Office Version
  1. 2019
Platform
  1. Windows
Can I instead of copying the data from the different workbooks by row, place by column (identifying the last empty cell)?
 

Attachments

  • 1.png
    1.png
    69.3 KB · Views: 3

Watch MrExcel Video

Forum statistics

Threads
1,129,790
Messages
5,638,322
Members
417,020
Latest member
MSVII

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top