Public Sub GetDirXlsContents()
' Source sheet name, Source directory path, Source cell Range
Call CopyFromEachFileInPath("Sheet1", "C:\test", "A1:I500")
End Sub
Private Sub CopyFromEachFileInPath(SheetName, Path, Rng)
Dim fs, f, f1, fc, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Path & "\")
Set fc = f.Files
' make a temp sheet
Application.ScreenUpdating = False
TargSh = ActiveSheet.Name
Sheets.Add
TempSh = ActiveSheet.Name
Sheets(TargSh).Activate
Application.ScreenUpdating = True
For Each f1 In fc
With Sheets(TempSh)
' clear temp sheet and start again
.Cells.ClearContents
' Place Src Info on Temp Targ Sheet
If Right(f1.Name, 3) = "xls" Then
fName = Left(f1.Name, Len(f1.Name) - 4)
.Range(Rng).FormulaArray = "='" & Path & "\[" & fName & "]" & SheetName & "'!" & Rng
.Range(Rng).Value = .Range(Rng).Value
'GetValuesFromAClosedWorkbook Path, f1.Name, SheetName, "A1:K30"
End If
' if columD = 1 copy over
For Each A In .Columns("A:A").SpecialCells(xlCellTypeConstants, 3)
NxRw = Cells(65536, 1).End(xlUp).Row + 1
If Not A.Value = 0 And A.Offset(1, 0).Value = 0 Then ' copy to final sheet
Range("A" & NxRw & ":I" & NxRw).Value = .Range("A" & A.Row & ":Z" & A.Row).Value
Range("J" & NxRw).Value = fName
End If
Next A
End With
' have user see list build, so know not frozen
Cells(NxRw, 1).Select
Next ' workbook
' get rid of temp sheet
Application.DisplayAlerts = False
Sheets(TempSh).Delete
Application.DisplayAlerts = True
End Sub