Macro to copy data from closed excel files in different folders using folder and file name as criteria in destination table

[engrph]

I have a table with column B (folder name) and column C (file name) as the criteria.
Tables D to G are imported data say,"H2:K5", from other closed excel files saved in different folders.

I have a hundred of these files that are updated from time to time and I need to gather it all at once. Any macro ideas for these? Thank you.

 

[engrph]

I'm starting with this macro but I want it to loop through all the rows and stop which column B & C are blank. I'm still new with VBA. Your help is much appreciated!

Sub ImportData()
'Defines variables
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim sourceworkbook As String
' Define which workbook is which
Set wb1 = ThisWorkbook
' Note: File directory(C:\Users\engrph\Folder1\b100.xlsm) is inputted in cell "A2" in wb1 "Data1" sheet
sourceworkbook = ThisWorkbook.Worksheets("Data1").Range("A2")
Set wb2 = Workbooks.Open(sourceworkbook)
' Copy range "H2:K5" from the "Data2" sheet of wb2
wb2.Sheets("Data2").Range("H2:K5").Copy
' Paste the copied data to range "D2" of the "Data1" sheet in wb1
wb1.Sheets("Data1").Activate
    Range("D2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
' Save and Close wb2
wb2.Save
wb2.Close      
End Sub

 

[Kenneth Hobson]

Welcome to the forum!

(1) Yes, one can set the values on a run to open each workbook and fill in the values. This gives you flexibility to not insert 0's or such at that time. It can also add formats.

(2) Or, it could probably add the reference as an array formula in the macro run so that it stays current without action. Of course this method has some overhead as links would update on workbook open but than might be a good thing.

(2a) One might want to also use a sheet change event to update the array formula when B or C column values change.

Which would you like?

 

[engrph]

Welcome to the forum!

(1) Yes, one can set the values on a run to open each workbook and fill in the values. This gives you flexibility to not insert 0's or such at that time. It can also add formats.

(2) Or, it could probably add the reference as an array formula in the macro run so that it stays current without action. Of course this method has some overhead as links would update on workbook open but than might be a good thing.

(2a) One might want to also use a sheet change event to update the array formula when B or C column values change.

Which would you like?

Thanks Kenneth!

I think option (1) is what I'm looking for. Kindly direct me with the proper codes.

 

[Kenneth Hobson]

With threaded posts, there is seldom a need to fully quote a post. Just say, regarding post #2 if not responding directly after it.

Change the inputs and the sheet and ranges in GetObject() to copy to suit.

Always test on backup copy. Add to a Module:

Sub CopyFromClosedWorkbooks()
  Dim ws As Worksheet, b As Range, c As Range, p$, fn$
  Dim fso As Object, calc As Integer
  
  'Change INPUTS
  p = "C:\Users\lenovo1\Dropbox\Excel\Excel4Macro\"
  Set ws = Sheet2
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  calc = Application.Calculation
  Application.Calculation = xlCalculationManual
  
  With ws
    Set b = .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
  End With
  Set b = b.SpecialCells(xlCellTypeConstants)
  If b Is Nothing Then Exit Sub
  
  Set fso = CreateObject("Scripting.FileSystemObject")
   
  For Each c In b
    fn = p & c & "\" & c.Offset(, 1).Value
    If Not fso.FileExists(fn) Then GoTo NextC
    GetObject(fn).Worksheets("Sheet1").Range("A1:C3").Copy _
      c.Offset(, 2).Resize(3, 3)
NextC:
  Next c
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = calc
  Application.CutCopyMode = False
  Set fso = Nothing
End Sub

 

[Kenneth Hobson]

Add this after the GetObject().

Workbooks(c.Offset(, 1).Value).Close False

 

[engrph]

^
I have tried to modify the code but I get runtime error 1004: No cells were found on this particular line:

  Set aj = aj.SpecialCells(xlCellTypeConstants)

Here's the full code:

Sub Test4()
    Dim ws As Worksheet, aj As Range, ak As Range, p$, fn$
    Dim fso As Object, calc As Integer
    
    'Common file path inputted in cell AJ17
    p = ThisWorkbook.Worksheets("Flexure").Range("AJ17")
    Set ws = Sheet2
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    calc = Application.Calculation
    Application.Calculation = xlCalculationManual
With ws
    Set aj = .Range("AJ18", .Cells(.Rows.Count, "AJ").End(xlUp))
  End With
  Set aj = aj.SpecialCells(xlCellTypeConstants)
  If aj Is Nothing Then Exit Sub
  
  Set fso = CreateObject("Scripting.FileSystemObject")
   
  For Each ak In aj
    fn = p & ak & "" & ak.Offset(, 1).Value
    If Not fso.FileExists(fn) Then GoTo NextC
    GetObject(fn).Worksheets("Beam Design Forces").Range("AJ7:AL12").Copy _
      ak.Offset(, -34).Resize(6, 3)
NextC:
  Next ak
  
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = calc
    Application.CutCopyMode = False
    Set fso = Nothing
  
    ' Message if finished
    MsgBox "Completed!"
End Sub

Below figure shows what I'm trying to achieve.

From: B1_RB-1.xlsm, AJ7:AL12
To: Summary.xlsm, C18:E23

From B17_RB-2.xlsm, AJ7:AL12
To: Summary.xlsm, C24:E29

..and so on and so forth..