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
 
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值