将多个 excel 文件中的特定值复制到一个表中

Question

我正在尝试从 400 多个 excel 文件中复制 22 个值，并将这些值以特定格式放入新工作表中。 第一个文件中的所有值都应在第 1 行及其各自的列中结束，文件 2 中的所有值应在第 2 行中结束，依此类推。 我试过让 VBA 一个一个地打开源文件并使用这种方法复制一些数据： https://www.encodedna.com/excel/read-multiple-excel-files-and-merge- data-to-single-file-using-vba.htm但我似乎无法让它像我想要的那样工作。

你们有什么好的想法或方法可以将 400 张纸中的每张纸中的 H8、H9、H10 复制到一张集体纸上。 我不需要从源文件的所有行和列中循环，因为我知道我需要复制的特定 cel。 希望你能帮忙！

Answer 1

循环遍历要从中复制的范围内的单元格。 每次复制后增加目标列，每个文件后增加目标行。

Option Explicit

Sub ProcessFiles()

    ' specific cells to copy to colums 1 to 22
    Const RNG_COPY = "A10,A11,A3:H1,A2:H2,A3:F3"
    Const Folder = "C:\temp\so\" ' folder with multiple sheets
    Const SHT_OUT = "Sheet1" ' results sheet
 
    Dim FSO As Object, objFile, objFolder, SelectedFolder As String
    Dim wbIn As Workbook, ws As Worksheet, wsIn As Worksheet
    Dim cell As Range, r As Long, c As Integer
    
    ' select files to merge
    Set FSO = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Folder
        .InitialView = msoFileDialogViewList
        .Show
        SelectedFolder = .SelectedItems(1)
    End With

    Set objFolder = FSO.getFolder(SelectedFolder)
    Set ws = ThisWorkbook.Sheets(SHT_OUT)
    r = 0 ' target row

    Application.ScreenUpdating = False
    For Each objFile In objFolder.Files
        If objFile.Name Like "*.xls*" Then
            Set wbIn = Workbooks.Open(objFile.Path, True, True)
            Set wsIn = wbIn.Sheets(1)
    
            ' copy values to target row
            r = r + 1
            c = 1
            For Each cell In wsIn.Range(RNG_COPY).Cells
                ws.Cells(r, c) = cell
                c = c + 1
            Next
            wbIn.Close False
         End If
    Next
    Application.ScreenUpdating = True
    MsgBox r & " files processed from " & SelectedFolder, vbInformation

End Sub