vba - VBA - 打开多个文件，复制并粘贴到新文件

Question

VBA - 随着典型问题的开始，我是 VBA 的新手（全新）。我想打开一个电子表格，允许我从一个文件夹中打开多个文件（未确定的数量）。然后它将从每个文件中选择某些单元格，将它们复制并粘贴到我的原始电子表格中。当然，然后关闭所有其他文件。

Answer 1

See if this will help. Because we're copying from an irregular (non-contiguous) range, it's a bit difficult to copy to another irregular range. So for that reason, the target range is "A1,B1,C1,D1,E1, etc", instead of "A1,B1,C1,E1,H1, etc". If that doesn't work for you, we'll need to try something a bit more elaborate.

Sub copyMultFiles()
    Dim rS As Range, rT As Range, Cel As Range
    Dim wBs As Workbook 'source workbook
    Dim wS As Worksheet 'source sheet
    Dim wT As Worksheet 'target sheet
    Dim x As Long 'counter
    Dim c As Long
    Dim arrFiles() As String 'list of source files
    Dim myFile As String 'source file

    '    change these to suit requirements
    Const csMyPath As String = "C:\Documents and Settings\Dave\Desktop\TestFolder\" 'source folder
    Const csMyFile As String = "*.xls" 'source search pattern
    Const csSRng As String = "$C$1,$C$10,$C$11,$C$34,$D$1" 'source range
    Const csTRng As String = "$A$1" 'target range

    Application.ScreenUpdating = False

    '   target sheet
    Set wT = ThisWorkbook.Worksheets(1) 'change to suit
    '   clear sheet
    wT.Cells.Clear 'may not want this, comment out!!!

'   aquire list of files
    ReDim arrFiles(1 To 1)
    myFile = Dir$(csMyPath & csMyFile, vbNormal)
    Do While Len(myFile) > 0
        arrFiles(UBound(arrFiles)) = myFile
        ReDim Preserve arrFiles(1 To UBound(arrFiles) + 1)
        myFile = Dir$
    Loop
    ReDim Preserve arrFiles(1 To UBound(arrFiles) - 1)

    Set rT = wT.Range(csTRng)

    ' loop thru list of files
    For x = 1 To UBound(arrFiles)
        Set wBs = Workbooks.Open(csMyPath & arrFiles(x), False, True) 'open wbook
        Set wS = wBs.Worksheets(1) 'change sheet to suit

        c = 0
        Set rS = wS.Range(csSRng)
        'copy source range to current target row
        For Each Cel In rS
            Cel.Copy rT.Offset(, c) 'next column
            c = c + 1
        Next Cel

        wBs.Close False
        Set rT = rT.Offset(1) 'next row
        DoEvents
    Next x 'next book

    Erase arrFiles

    Application.ScreenUpdating = True

End Sub