将数据从多个工作簿复制到另一个工作簿 [英] Copying data from multiple workbooks to another

问题描述

我有一个包含两页的工作簿:

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

结果"包含一个空表，在第1行中包含标题.

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

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

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.

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

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.

应对文件夹中的每个工作簿重复此操作，将数据插入结果"表中的第一行空白(可以视为A列中的第一个空白单元格).

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.

这就是我所拥有的:

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

当前宏在ResultRow = destsheet.Range("A1").End(xlDown).Offset(1, 0) '.End(xlDown).Offset(1, 0).Row处停止，出现运行时错误1004:应用程序错误或对象定义的错误".

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

有什么想法吗?

推荐答案

我认为您的真正问题是您试图在一条语句中做太多事情.这意味着您和其他任何人都无法查看您的代码，也无法看到它正在尝试执行的操作.您的代码越复杂，完成它所需的时间就越长，并且在六个月内必须对其进行更新时，就需要越长的时间来理解它.下面的代码可能需要稍长的时间才能运行，但易于理解和更新.

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.

替换:

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

作者:

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

添加以下变量

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

将您的Do循环替换为:

Replace your Do loop with:

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".

这篇关于将数据从多个工作簿复制到另一个工作簿的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！