Question

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

Answer 1

看看这是否有帮助。因为我们从不规则（非连续）范围复制，所以复制到另一个不规则范围有点困难。因此，目标范围是“A1，B1，C1，D1，E1等”，而不是“A1，B1，C1，E1，H1等”。如果这对你不起作用，我们需要尝试一些更精细的东西。

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

VBA - 打开，复制和粘贴到新文件的多个文件

1 个答案: