vba 将数据从多个工作簿复制到另一个

Copying data from multiple workbooks to another

提问by meepmeep

I have a workbook which has two sheets:

我有一本工作簿，里面有两张纸：

'Data Processing' contains a list of cell references as follows:

“数据处理”包含一个单元格引用列表，如下所示：

Input Column    Input Row Start Input Row End       Output Column
C               88              105                 A
H               198             215                 B
G               253             270                 C

'Results' contains an empty table with headers in row 1.

“结果”包含一个空表，第 1 行有标题。

I want a VBA macro which opens every .xls file in the current folder, and copies data from the first sheet of each one into the 'Results' sheet according to the table of data.

我想要一个 VBA 宏，它打开当前文件夹中的每个 .xls 文件，并根据数据表将每个文件的第一张表中的数据复制到“结果”表中。

For example, the first workbook should be opened, and the data held in C88:C105 should be copied into column A of 'Results', followed by H198:H215 into row B, followed by G253:G270 into column C.

例如，应打开第一个工作簿，将 C88:C105 中保存的数据复制到“结果”的 A 列，然后将 H198:H215 复制到 B 行，然后将 G253:G270 复制到 C 列。

This should be repeated for each workbook in the folder, the data being inserted into the first blank row (which can be taken as the first blank cell in column A) in the 'Results' sheet.

应该对文件夹中的每个工作簿重复此操作，将数据插入到“结果”表中的第一个空白行（可以作为 A 列中的第一个空白单元格）中。

This is what I have:

这就是我所拥有的：

Sub Consolidate()

Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String


Set destsheet = Workbooks("Consolidate_data.xlsm").Worksheets("Results")

'get list of all files in folder
Fname = Dir(ThisWorkbook.Path & "/*.xls")

'loop through each file in folder (excluding this one)
Do While Fname <> "" And Fname <> ThisWorkbook.Name
    Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
    Set originsheet = wkbkorigin.Worksheets("Sheet1")

    'find first empty row in destination table
    ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0).Row 

    'start at top of list of cell references and work down until empty cell reached
    Application.Goto ThisWorkbook.Worksheets("Data Processing").Range("A2")

    Do While IsEmpty(ActiveCell) = False
        originsheet.Range(ActiveCell.Value & ActiveCell.Offset(0, 1).Value & ":" & ActiveCell.Value & ActiveCell.Offset(0, 2).Value).Copy
        destsheet.Range(ActiveCell.Offset(0, 4).Value & ResultRow & ":" & ActiveCell.Offset(0, 4).Value & (ResultRow + (ActiveCell.Offset(0, 2).Value - ActiveCell.Offset(0, 1).Value))).PasteSpecial
        ActiveCell.Offset(1, 0).Select
    Loop
    Workbooks(Fname).Close SaveChanges:=False   'close current file
    Fname = Dir     'get next file
Loop
End Sub

Currently the macro stops at ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0) '.End(xlDown).Offset(1, 0).Rowwith 'Run time error 1004: Application error or object-defined error'.

目前，宏在ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0) '.End(xlDown).Offset(1, 0).Row“运行时错误 1004：应用程序错误或对象定义错误”处停止。

Any ideas?

有任何想法吗？

回答by JMax

Use Option Explicit

使用选项显式

You should declare allyour variables. Excel can help you with that if you use the Option Explicit.

您应该声明所有变量。如果您使用Option Explicit.

Error origin

错误来源

In your case :

在你的情况下：

destsheet.Range("A1").End(xlDown).Offset(1, 0)returns a Range

destsheet.Range("A1").End(xlDown).Offset(1, 0)返回一个 Range

but you may want ResultRowto be a Long

但你可能想ResultRow成为Long

You should either use :

您应该使用：

for a Range:

对于范围：

Set ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0)

or for a Long:

或长：

ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0).Row

回答by Tony Dallimore

I think your real problem is that you are trying to do too much in one statement. This means that neither you nor anyone else can look at your code and see what it is trying to do. The more complex your code, the longer it takes you to get it right and the longer it will take you to understand it when you have to update it in six months time. The code below might take marginally longer to run but it is easy to understand and easy to update.

我认为你真正的问题是你试图在一个声明中做太多事情。这意味着您和其他任何人都无法查看您的代码并了解它正在尝试做什么。你的代码越复杂，你做对的时间就越长，当你必须在六个月内更新它时，你理解它的时间也就越长。下面的代码可能需要稍长的时间来运行，但它很容易理解，也很容易更新。

This code is not quite how I would have done but I have tried to follow your style.

这段代码不是我应该做的，但我试图遵循你的风格。

Replace:

代替：

ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0).Row

by:

经过：

ResultRow = destsheet.Cells(Rows.Count, "A").End(xlUp).Row + 1

Add the following variables

添加以下变量

Dim ColDest As String
Dim ColSrc As String
Dim RngDest As String
Dim RngSrc As String
Dim RowInstructCrnt As Long
Dim RowSrcEnd As Long
Dim RowSrcStart As Long

Replace your Do loop with:

将您的 Do 循环替换为：

RowInstructCrnt = 2
With ThisWorkbook.Worksheets("Data Processing")
  Do While Not IsEmpty(.Cells(RowInstructCrnt, "A"))
    ColSrc = .Cells(RowInstructCrnt, "A")
    RowSrcStart = .Cells(RowInstructCrnt, "B")
    RowSrcEnd = .Cells(RowInstructCrnt, "C")
    ColDest = .Cells(RowInstructCrnt, "D")
    RngSrc = ColSrc & RowSrcStart & ":" & ColSrc & RowSrcEnd
    RngDest = ColDest & ResultRow
    originsheet.Range(RngSrc).Copy
    destsheet.Range(RngDest).PasteSpecial
    RowInstructCrnt = RowInstructCrnt + 1
 Loop
End With

Note: not only is each statement of the above code a single step, it does not move the cursor around the worksheet "Data Processing".

注意：以上代码的每条语句不仅是单步执行，而且不会在“数据处理”工作表周围移动光标。

回答by meepmeep

Solution (as in comments above) was the following:

解决方案（如上面的评论）如下：

ResultRow = destsheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row