VBA/Macros extracting data from multiple files in a directory as well as the location the data came from

skylarjung

New Member
Joined
Sep 3, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
Hello,
I am looking to extract data from multiple files in a directory within the same range and put them into a "Master Worksheet". In addition I want to also insert a column right next to the previously inserted data and have the filename that the data came from.
I already have a code that I found that goes into the directory I want and extracts the data (per this forum) however I am not sure how to also insert the file name right next to the data that was inserted. Is there an easy way to do this?

VBA Code:
Sub ExtracData()



Dim summary As Workbook

Dim wb As Workbook

Dim directory As String

Dim fileName As String

Dim NextRow As Long



Application.DisplayAlerts = False

Application.ScreenUpdating = False





directory = "C:\Users\hidden\Downloads\CRT\"

fileName = Dir(directory & "*.xl*")

Set summary = ThisWorkbook



Do While fileName <> ""

If fileName <> ThisWorkbook.Name Then

Set wb = Workbooks.Open(directory & fileName)

wb.Worksheets("Hidden").Range("A10:A1000").Copy  'heres where it copies the range but I also need to insert the file name in the column next to it

summary.Activate

NextRow = Cells(Rows.Count, "A").End(xlUp).Row + 1

Worksheets("Sheet1").Range("A" & NextRow).Select

Selection.PasteSpecial Paste:=xlPasteAll, operation:=xlNone, SkipBlanks:=False, Transpose:=False

wb.Close savechanges:=False

End If

fileName = Dir

Loop



Application.DisplayAlerts = True

Application.ScreenUpdating = True



MsgBox "Automation Complete"

End Sub
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
65,608
Office Version
  1. 365
Platform
  1. Windows
Hi & welcome to MrExcel.
Will A10:A1000 always have values in every cell?
 

skylarjung

New Member
Joined
Sep 3, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
Hi & welcome to MrExcel.
Will A10:A1000 always have values in every cell?
Yes. Hoever if you know a way to say all cells from A:10 to the end that would be better.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
65,608
Office Version
  1. 365
Platform
  1. Windows
Ok, how about
VBA Code:
Sub ExtracData()
   Dim wb As Workbook
   Dim Pth As String
   Dim FName As String
   Dim UsdRws As Long

   Application.DisplayAlerts = False
   Application.ScreenUpdating = False
   
   Pth = "C:\Users\hidden\Downloads\CRT\"
   FName = Dir(Pth & "*.xl*")
   
   With ThisWorkbook.Sheets("Sheet1")
      Do While FName <> ""
         If FName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(Pth & FName)
            UsdRws = wb.Worksheets("Hidden").Range("A" & Rows.Count).End(xlUp).Row
            With .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(UsdRws - 9)
               .Value = wb.Worksheets("Hidden").Range("A10:A" & UsdRws).Value
               .Offset(, 1).Value = FName
            End With
            wb.Close False
         End If
         FName = Dir
      Loop
   End With
      
   Application.DisplayAlerts = True
   
   MsgBox "Automation Complete"

End Sub
 

skylarjung

New Member
Joined
Sep 3, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
Ok, how about
VBA Code:
Sub ExtracData()
   Dim wb As Workbook
   Dim Pth As String
   Dim FName As String
   Dim UsdRws As Long

   Application.DisplayAlerts = False
   Application.ScreenUpdating = False
  
   Pth = "C:\Users\hidden\Downloads\CRT\"
   FName = Dir(Pth & "*.xl*")
  
   With ThisWorkbook.Sheets("Sheet1")
      Do While FName <> ""
         If FName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(Pth & FName)
            UsdRws = wb.Worksheets("Hidden").Range("A" & Rows.Count).End(xlUp).Row
            With .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(UsdRws - 9)
               .Value = wb.Worksheets("Hidden").Range("A10:A" & UsdRws).Value
               .Offset(, 1).Value = FName
            End With
            wb.Close False
         End If
         FName = Dir
      Loop
   End With
     
   Application.DisplayAlerts = True
  
   MsgBox "Automation Complete"

End Sub
This worked! Thank you for your help!
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
65,608
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Forum statistics

Threads
1,147,560
Messages
5,741,825
Members
423,689
Latest member
Jords998

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