VBA 经典示例

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