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

Long time reader and admirer of *.

长期阅读和崇拜*。

Basically I am trying to to loop through a series of Excel files to copy a range of data and paste it on a single Excel workbook/sheet.

基本上，我正在尝试循环通过一系列Excel文件来复制一系列数据，并将其粘贴到一个Excel工作簿/表单上。

The cell range location (C3:D8, D3:E8) is not always consistent, but the table dimensions are: 29 R x 2 C. Also, the files only have 1 sheet, and aside from the table dimensions specified, no data values in other cells.

单元格范围位置(C3:D8, D3:E8)并不总是一致的，但是表维度是:29rx2c。此外，文件只有一张表，除了指定的表维度外，其他单元格中没有数据值。

In its current form the code is executing, but not pasting anything to its destination Excel file.

在当前格式中，代码正在执行，但没有将任何内容粘贴到目标Excel文件。

I need it to

我需要它

Find the data dimension in file (table)
在文件(表)中查找数据维度
Copy the table
复制表
Paste to destination (below previous table)
粘贴到目的地(在下面的表中)
Loop through to next file
循环到下一个文件。
Repeat Step 1-4
重复步骤1 - 4

The code is from: Excel VBA: automating copying ranges from different workbooks into one final destination sheet?

代码来自:Excel VBA:将不同工作簿中的内容自动复制到最终的目标表中?

Thanks a lot for any help, I really appreciate it and please feel tell me to specify anything if my question is vague.

非常感谢您的帮助，我非常感谢，如果我的问题含糊不清，请告诉我具体的内容。

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

1 个解决方案

#1

The below should achieve what you're after.

以下是你想要的。

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

Ensure you copy both of the functions across, they're used to create the dimensions of the table, and then copying the table.

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

You will need to amend the sheet name variables. Let me know if you have any questions.

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

You need to amend the range of where the workbook names are stored. You need to pass the column number in, so that the last row can be calculated. You can also amend the column in which data is pasted back into the workbook.

您需要修改工作簿名称存储的范围。您需要将列号传入，以便计算最后一行。您还可以修改将数据粘贴回工作簿中的列。

#1