excel - VBA - 从多个 Excel 文件复制和粘贴到单个 Excel 文件

Question

StackOverflow 的长期读者和崇拜者。

基本上，我试图遍历一系列 Excel 文件以复制一系列数据并将其粘贴到单个 Excel 工作簿/工作表上。

单元格范围位置 (C3:D8, D3:E8) 并不总是一致的，但表格尺寸为:29 R x 2 C。此外，文件只有 1 张工作表，除了指定的表格尺寸外，其他单元格中没有数据值。

代码以其当前形式执行，但未将任何内容粘贴到其目标 Excel 文件。

我需要它

1. 查找文件(表)中的数据维度
2. 复制表格
3. 粘贴到目的地(在上表下方)
4. 循环到下一个文件
5. 重复步骤 1-4

代码来自: Excel VBA: automating copying ranges from different workbooks into one final destination sheet?

非常感谢您的帮助，我真的很感激，如果我的问题含糊不清，请告诉我具体说明。

Sub SourcetoDest()

    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Dim sDestPath As String
    Dim sSourcePath As String
    Dim shDest As Worksheet
    Dim rDest As Range
    Dim vaFiles As Variant
    Dim i As Long

    'array of folder names under sDestPath

    'array of file names under vaFiles
    vaFiles = Array("Book1.xls")

    sDestPath = "C:\Users"
    sSourcePath = "C:\Users"


    Set wbDest = Workbooks.Open(sDestPath & "\" & "Book2.xlsm")
    Set shDest = wbDest.Sheets(1)

    'loop through the files
    For i = LBound(vaFiles) To UBound(vaFiles)
        'open the source
        Set wbSource = Workbooks.Open(sSourcePath & "\" & vaFiles(i))

        'find the next cell in col C
        Set rDest = shDest.Cells(shDest.Rows.Count, 3).End(xlUp).Offset(1, 0)
        'write the values from source into destination
        rDest.Resize(5, 1).Value = wbSource.Sheets(1).Range("C7:D33").Value


        wbSource.Close False
    Next i

End Sub

Answer 1

下面应该实现你所追求的。

Option Explicit
Sub copy_rng()
    Dim wb As Workbook, wbDest As Workbook, ws As Worksheet, wsDest As Worksheet, wsSrc As Worksheet
    Dim wbNames() As Variant
    Dim destFirstCell As Range
    Dim destColStart As Integer, destRowStart As Long, i As Byte
    Dim destPath As String

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1") ' Amend to your sheet name
    Set wsSrc = wb.Sheets("Sheet2") ' Amend to sheet name with table data
    wbNames = ws.Range("A2:A" & lrow(1, ws)) ' Pass col number into lrow function
    destPath = "C:\Users\"

    Application.ScreenUpdating = False
    For i = 1 To UBound(wbNames, 1)
        Set wbDest = Workbooks.Open(destPath & wbNames(i, 1))
        Set wsDest = wbDest.Worksheets(1)
        With wsDest
            Set destFirstCell = .Cells.Find(What:="*")
            destColStart = destFirstCell.Column
            destRowStart = destFirstCell.Row
            .Range(Cells(destRowStart, destColStart), _
                Cells(lrow(destColStart, wsDest), icol(destRowStart, wsDest))).Copy
        End With
        wsSrc.Cells(lrow(1, wsSrc) + 1, 1).PasteSpecial Paste:=xlPasteAll
        wbDest.Close False
    Next i
    Application.ScreenUpdating = True

End Sub

Function lrow(ByVal col_num As Integer, sheet_name As Worksheet) As Long
    lrow = sheet_name.Cells(Rows.Count, col_num).End(xlUp).Row
End Function

Function icol(ByVal row_num As Long, sheet_name As Worksheet) As Integer
    icol = sheet_name.Cells(row_num, Columns.Count).End(xlToLeft).Column
End Function

确保复制这两个函数，它们用于创建表格的维度，然后复制表格。

您将需要修改工作表名称变量。如果您有任何问题，请告诉我。

您需要修改工作簿名称的存储范围。需要把列号传进去，这样才能算出最后一行。您还可以修改将数据粘贴回工作簿的列。