Copy a Range from each workbook
Sub TestFile1() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim i As Long Dim a As Long Application.ScreenUpdating = False With Application.FileSearch .NewSearch .LookIn = "C:/Data" .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then Set basebook = ThisWorkbook rnum = 1 For i = 1 To .FoundFiles.Count Set mybook = Workbooks.Open(.FoundFiles(i)) Set sourceRange = mybook.Worksheets(1).Range("a1:c5") a = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, 1) sourceRange.Copy destrange mybook.Close rnum = rnum + a Next i End If End With Application.ScreenUpdating = True End Sub
Sub TestFile1_values() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim i As Long Dim a As Long Application.ScreenUpdating = False With Application.FileSearch .NewSearch .LookIn = "C:/Data" .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then Set basebook = ThisWorkbook rnum = 1 For i = 1 To .FoundFiles.Count Set mybook = Workbooks.Open(.FoundFiles(i)) Set sourceRange = mybook.Worksheets(1).Range("a1:c5") a = sourceRange.Rows.Count With sourceRange Set destrange = basebook.Worksheets(1).Cells(rnum, 1). _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value mybook.Close rnum = rnum + a Next i End If End With Application.ScreenUpdating = True End Sub
Copy a column or columns from each workbook
Remember Excel have only 256 columns.
Sub TestFile2() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim cnum As Integer Dim i As Long Dim a As Integer Application.ScreenUpdating = False With Application.FileSearch .NewSearch .LookIn = "C:/Data" .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then Set basebook = ThisWorkbook cnum = 1 For i = 1 To .FoundFiles.Count Set mybook = Workbooks.Open(.FoundFiles(i)) Set sourceRange = mybook.Worksheets(1).Columns("A:A") a = sourceRange.Columns.Count Set destrange = basebook.Worksheets(1).Cells(1, cnum) sourceRange.Copy destrange mybook.Close cnum = cnum + a Next i End If End With Application.ScreenUpdating = True End Sub
Sub TestFile2_values() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim cnum As Integer Dim i As Long Dim a As Integer Application.ScreenUpdating = False With Application.FileSearch .NewSearch .LookIn = "C:/Data" .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then Set basebook = ThisWorkbook cnum = 1 For i = 1 To .FoundFiles.Count Set mybook = Workbooks.Open(.FoundFiles(i)) Set sourceRange = mybook.Worksheets(1).Columns("A:A") a = sourceRange.Columns.Count With sourceRange Set destrange = basebook.Worksheets(1).Columns(cnum). _ Resize(, .Columns.Count) End With destrange.Value = sourceRange.Value mybook.Close cnum = cnum + a Next i End If End With Application.ScreenUpdating = True End Sub
Copy a sheet from each workbook into your workbook
This macro will copy the first sheet of each workbook into the workbook where the code is in. The sheet will be named as the workbook name..
Sub TestFile3() Dim basebook As Workbook Dim mybook As Workbook Dim i As Long Application.ScreenUpdating = False With Application.FileSearch .NewSearch .LookIn = "C:/Data" .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then Set basebook = ThisWorkbook For i = 1 To .FoundFiles.Count Set mybook = Workbooks.Open(.FoundFiles(i)) mybook.Worksheets(1).Copy after:= _ basebook.Sheets(basebook.Sheets.Count) ActiveSheet.Name = mybook.Name mybook.Close Next i End If End With Application.ScreenUpdating = True End Sub
Sub TestFile3_values() Dim basebook As Workbook Dim mybook As Workbook Dim i As Long Application.ScreenUpdating = False With Application.FileSearch .NewSearch .LookIn = "C:/Data" .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then Set basebook = ThisWorkbook For i = 1 To .FoundFiles.Count Set mybook = Workbooks.Open(.FoundFiles(i)) mybook.Worksheets(1).Copy after:= _ basebook.Sheets(basebook.Sheets.Count) ActiveSheet.Name = mybook.Name With ActiveSheet.UsedRange .Value = .Value End With mybook.Close Next i End If End With Application.ScreenUpdating = True End Sub
Copy a range from each workbook with a file name starting with ?
This example do the same as TestFile1, but this one only copy from workbooks
with a file name that start with "Test".
It will use a function to get the file name without the path for checking the the first characters.
Change this line to your situation. If Left(sFname, 4) = "Test" Then
Function Split97(sStr As Variant, sdelim As String) As Variant
' Tom Ogilvy
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
Sub TestFile4() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim i As Long Dim a As Long Dim vArr As Variant Dim sFname As String
Application.ScreenUpdating = False With Application.FileSearch .NewSearch .LookIn = "C:/Data" .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then Set basebook = ThisWorkbook rnum = 1 For i = 1 To .FoundFiles.Count vArr = Split97(.FoundFiles(i), "/") sFname = vArr(UBound(vArr)) If Left(sFname, 4) = "Test" Then Set mybook = Workbooks.Open(.FoundFiles(i)) Set sourceRange = mybook.Worksheets(1).Range("a1:c5") a = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, 1) sourceRange.Copy destrange mybook.Close rnum = rnum + a End If Next i End If End With Application.ScreenUpdating = True End Sub
Sub TestFile4_Values() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim i As Long Dim a As Long Dim vArr As Variant Dim sFname As String Application.ScreenUpdating = False With Application.FileSearch .NewSearch .LookIn = "C:/Data" .SearchSubFolders = False .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then Set basebook = ThisWorkbook rnum = 1 For i = 1 To .FoundFiles.Count vArr = Split97(.FoundFiles(i), "/") sFname = vArr(UBound(vArr)) If Left(sFname, 4) = "Test" Then Set mybook = Workbooks.Open(.FoundFiles(i)) Set sourceRange = mybook.Worksheets(1).Range("a1:c5") a = sourceRange.Rows.Count With sourceRange Set destrange = basebook.Worksheets(1).Cells(rnum, 1). _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value mybook.Close rnum = rnum + a End If Next i End If End With Application.ScreenUpdating = True End Sub