Скопируйте один и тот же диапазон ячеек из нескольких файлов Excel, используя VBA

Question

У меня есть макрос, который берет данные из одной рабочей книги и копирует их в другую рабочую книгу. В настоящее время установлено, что он копирует файлы из Book2.xlsx в Book1.xlsm. Это работает, только если у меня открыты Book2 и Book1. Однако я хотел бы использовать этот макрос, чтобы он выполнялся на всех файлах Excel в моей папке, например, если у меня есть также Book5.xlsm, Book15.xlsx и Book153.xlsx в папке C: \ Users \ JJ \ 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

Импорт из многих рабочих книг

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

Answer 2

Это код, который будет делать то, что делал ваш оригинальный код - многим. Извините, это немного объемно. Это потому, что я взял готовую функцию с полки, чтобы вы могли выбирать файлы. Вы можете выбрать один или несколько файлов, но все они должны находиться в одном каталоге.

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