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

[skylarjung]

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?

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

 

[Fluff]

Hi & welcome to MrExcel.
Will A10:A1000 always have values in every cell?

 

[skylarjung]

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]

Ok, how about

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]

Ok, how about

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]

You're welcome & thanks for the feedback.