以编程方式将数据从多个工作簿中的特定单元复制到“主工作簿" [英] Copying data from specific cells across multiple workbooks to 'master workbook' programmatically

问题描述

我有两个问题，但首先有一点背景...

I have two questions but first a bit of background...

我有许多工作簿，每个工作簿包含不同数量的工作表，所有工作表都保存在同一文件夹中.除第一个工作表外，每个工作表都有一张发票，我需要从中将特定单元格中的数据复制到主表上.

I have a number of workbooks each containing a different number of worksheets all saved in the same folder. Each worksheet except the first has an invoice from which I need data from specific cells copied on to the master sheet.

母版"表有5列，这些列将填充下一行每张表上相同5个单元格的信息.

The Master sheet has 5 columns which will be populated with the information from the same 5 cells on each sheet on the following row.

Invoice Sheets Cell  Master Sheet Row
     E9                   A
     D18                  B
     D22                  C
     E11                  D
     F27                  E

.

Sub Consolidate()

Dim wkbkorigin As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim ResultRow As Long
Dim Fname As String
Dim ColDest As String
Dim ColSrc As String
Dim RngDest As String
Dim RngSrc As String
Dim InvTotal As String
Dim RowInstructCrnt As Long
Dim RowSrcEnd As Long
Dim RowSrcStart As Long



Set destsheet = Workbooks("Test Master.xlsm").Worksheets("Sheet1")


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

'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.Cells(Rows.Count, "A").End(xlUp).Row + 1

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


   With ThisWorkbook.Worksheets("Sheet1")
  Do While Not IsEmpty(.Cells(16, 4))
    ColSrc = .Cells(9, 5)
    RowSrcStart = .Cells(18, 4)
    RowSrcEnd = .Cells(22, 4)
    ColDest = .Cells(11, 5)
    InvTotal = .Cells(27, 6)
    RngSrc = ColSrc & RowSrcStart & ColSrc & RowSrcEnd & InvTotal
    RngDest = ColDest & ResultRow
    originsheet.Range(RngSrc).Copy
    destsheet.Range(RngDest).PasteSpecial

 Loop
 End With
Workbooks(Fname).Close SaveChanges:=False   'close current file
    Fname = Dir     'get next file
Loop
End Sub

所以我的第一个问题是-如何修改此代码以使其将正确的信息粘贴到正确的单元格中...

So my first question is - how can I modify this code to make it paste the correct information in the correct cells...

第二-由于我不确定从哪里开始，我还没有尝试遍历工作簿中的每个工作表...

Secondly - I've not yet attempted looping through each sheet in the workbooks as I'm not sure where to begin...

任何建议将不胜感激

推荐答案

未经测试:

Sub Consolidate()

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


    Set destsheet = ThisWorkbook.Worksheets("Sheet1")
    Set RngDest = destsheet.Cells(Rows.Count, 1).End(xlUp) _
                       .Offset(1, 0).EntireRow
    Fname = Dir(ThisWorkbook.Path & "/*.xlsx")

    'loop through each file in folder (excluding this one)
    Do While Fname <> "" And Fname <> ThisWorkbook.Name

        If Fname <> ThisWorkbook.Name Then

            Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
            Set originsheet = wkbkorigin.Worksheets("Sheet1")

            With RngDest
                .Cells(1).Value = originsheet.Range("E9").Value
                .Cells(2).Value = originsheet.Range("D18").Value
                .Cells(3).Value = originsheet.Range("D22").Value
                .Cells(4).Value = originsheet.Range("E11").Value
                .Cells(5).Value = originsheet.Range("F27").Value
            End With

            wkbkorigin.Close SaveChanges:=False   'close current file
            Set RngDest = RngDest.Offset(1, 0)

        End If

        Fname = Dir()     'get next file
    Loop
End Sub

这篇关于以编程方式将数据从多个工作簿中的特定单元复制到“主工作簿"的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！