使用 VBA 从多个 Excel 文件中复制相同范围的单元格

Question

我有一个宏，它从一个工作簿中获取数据并将其复制到另一个工作簿中。 当前设置为将文件从 Book2.xlsx 复制到 Book1.xlsm。 只有当我打开 Book2 和 Book1 时它才有效。 但是，我想使用这个宏，以便它在我文件夹中的所有 Excel 文件上运行，例如，如果我在文件夹 C:\Users\JJ\ 中还有 Book5.xlsm、Book15.xlsx 和 Book153.xlsx Documents\Downloads，我想将所有这些文件中的单元格“D25:D26、D29:D32、D35”复制并粘贴到 Book1.xlsm 中。 如何使该过程自动化，这样我就不必每次都在代码中手动输入文件名？ 提前感谢您的帮助。

Sub Copy_Form_Below_Last_Cell() 
Dim wsDest As Worksheet
Dim lDestLastRow As Long
Set wsDest = Workbooks("Book1.xlsm").Worksheets("Sheet1")
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "H").End(xlUp).Offset(1).Row
Workbooks("Book2.xlsx").Worksheets("Sheet_2").Range("D25:D26, D29:D32, D35").Copy _
wsDest.Range("H" & lDestLastRow)     
wsDest.Activate
End Sub

Answer 1

对于许多人来说，这是可以执行您的原始代码所做的任何事情的代码。抱歉，内容有点多。那是因为我从我的书架上拿了一个准备好的功能来允许你选择文件。您可以选择一个或多个文件，但所有文件都必须位于同一目录中。

Sub CopyFormToNewRow()

    Dim FileNames As Variant
    Dim wsDest As Worksheet
    Dim Wb As Workbook
    Dim wsSrc As Worksheet
    Dim WasClosed As Boolean
    Dim Tmp As Variant
    Dim i As Integer

    FileNames = FileOpenName("Workbooks to process", "Excel workbooks|*.xlsx", Multi:=True)
    If Not IsEmpty(FileNames) Then
        Set wsDest = Workbooks("Book1.xlsm").Worksheets("Sheet1")

        Application.ScreenUpdating = False
        For i = 1 To UBound(FileNames)
            On Error Resume Next
            Tmp = Split(FileNames(i), "\")
            Set Wb = Workbooks(Tmp(UBound(Tmp)))
            If Err Then
                Set Wb = Workbooks.Open(FileNames(i))
            End If
            WasClosed = CBool(Err.Number)

            On Error GoTo 0
            Set wsSrc = Wb.Worksheets("Sheet_2")
            ' I would prefer: Set wsSrc = Wb.Worksheets(1), meaning first worksheet
            With wsDest
                wsSrc.Range("D25:D26, D29:D32, D35").Copy _
                      Destination:=.Cells(.Rows.Count, "H").End(xlUp).Offset(1)
            End With
            If Not WasClosed Then Wb.Close SaveChanges:=False
        Next i

        Application.ScreenUpdating = True
    End If
End Sub

Function FileOpenName(ByVal Title As String, _
                      Optional ByVal Fltr As String, _
                      Optional ByVal Pn As String, _
                      Optional ByVal Multi As Boolean) As Variant
    ' SSY 050 28 Jan 2020

    ' ==================================================
    '   Parameters:
    '       Title             = Form's title
    '       Fltr              = Specify filters by structured string
    '                           i.e. "Excel workbooks|*.xl*||Word documents|*.doc*"
    '                           in sequence of position assignment.
    '                           separator = Chr(124) - single and double
    '                           Default = no filter [=All files]
    '       Pn                  = Initial path: [=Last used]

    ' ==================================================
    '   Return                = Single file Ffn string or a 1-based array
    '                           Return IsEmpty if no selection was made

    ' ==================================================
    '   Note:   The ButtonName is "Open" by default. Another setting
    '           doesn't take effect until a file has been selected.

    ' ==================================================

    Const FltDesc As Long = 0, FltExt As Long = 1

    Dim Fun As Variant                              ' return variant
    Dim Fod As FileDialog                           ' File Open Dialog
    Dim Flt() As String                             ' all filters
    Dim Sp() As String                              ' split filter
    Dim i As Long

    ' ==================================================

    Flt = Split(Fltr, "||")

    Set Fod = Application.FileDialog(msoFileDialogFilePicker)
    With Fod
        .Filters.Clear
        For i = 0 To UBound(Flt)
            If Len(Flt(i)) Then
                Sp = Split(Flt(i), "|")
                .Filters.Add Sp(FltDesc), Sp(FltExt), i + 1
                .FilterIndex = 1
            End If
        Next i
        .Title = Title
        .AllowMultiSelect = Multi
        .InitialFileName = Pn
        If .Show Then
            With .SelectedItems
                If Multi Then
                    ReDim Fun(.Count)
                    For i = 1 To .Count
                        Fun(i) = .Item(i)
                    Next i
                Else
                    Fun = .Item(1)
                End If
            End With
        End If
    End With

    FileOpenName = Fun
End Function

Answer 2

从许多工作簿导入

Option Explicit

Sub Copy_Form_Below_Last_Cell()

    Const cFolder As String = "C:\Users\JJ\Documents\Downloads"
    Const cDest As String = "Sheet1"                ' Destination Worksheet Name
    Const cSource As String = "Sheet_2"             ' Source Worksheet Name
    Const cRng As String = "D25:D26, D29:D32, D35"  ' Source Range Address
    Const cExt As String = "*.xl*"                  ' File Extensions
    Const cCol As Long = 8                          ' Destination Column Number

    Dim wbSource As Workbook                        ' Source Workbook
    Dim wsDest As Worksheet                         ' Destination Worksheet
    Dim CPR As Long                                 ' Current Paste Row
    Dim strName As String                           ' Current File Name

    Set wsDest = ThisWorkbook.Worksheets(cDest)

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With

    ' Handle errors.
    On Error GoTo ErrorHandler

    ' Loop through all workbooks in Source Folder.
    strName = Dir(cFolder & "\" & cExt)
    Do While Len(strName) > 0  ' and strname<>
        Set wbSource = Workbooks.Open(cFolder & "\" & strName)
        CPR = wsDest.Cells(wsDest.Rows.Count, cCol).End(xlUp).Row + 1
        wbSource.Worksheets(cSource).Range(cRng).Copy wsDest.Cells(CPR, cCol)
        wbSource.Close False
        strName = Dir
    Loop

ProcedureExit:

    ' Speed down.
    With Application
        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:
    MsgBox "An unexpected error occurred."
    On Error GoTo 0
    GoTo ProcedureExit

End Sub