Question

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

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

主表格有5列，其中将填充来自下一行每张纸上相同5个单元格的信息。

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

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

其次 - 我还没有尝试遍历工作簿中的每个工作表，因为我不知道从哪里开始......

非常感谢任何建议

Answer 1

未测试：

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

将来自多个工作簿中特定单元格的数据以编程方式复制到“主工作簿”

1 个答案: