Excel VBA - 复制某些单元格并粘贴到同一工作表中的其他单元格旁边

Question

我有一些代码将遍历我的工作表并找到 A 列中每个具有“项目”值的单元格。然后，它会直接复制具有“项目”值的单元格下方的整行。

我想做的是：

• 浏览工作表并找到“发票”、“发票日期”和“城市”的每个实例
• 找到这些单元格后，复制这些单元格并立即将这些单元格复制到其右侧
• 然后遍历并找到 A 列中值为“Item”的每个单元格，并将两个复制的单元格粘贴（转置）到该行的下一个空白列。
• 然后我将复制“项目”下方的行，并使用下面已经编写的代码

这是我目前拥有的代码，以及几张我想做的图片。

请多多包涵，因为我昨天刚开始学习 VBA，而且我很新。我知道如何做一些较小的部分，但整个过程对我来说仍然是模糊的。任何建议表示赞赏。谢谢！

' Copy rows from one workbook to another at each instance of "Item"
Dim fromBook As Workbook
Dim toBook As Workbook

Application.ScreenUpdating = False

Set fromBook = Workbooks("from.xlsm")
Set toBook = Workbooks("to.xlsm")

Dim i As Range

For Each i In fromBook.Sheets("Sheet1").Range("A1:A1000")
    Select Case i.Value
        Case "Item"
            toBook.Sheets("Sheet2").Range("A" & toBook.Sheets("Sheet2").Rows.Count).End(xlUp).Offset(1, 0).EntireRow.Value = i.Offset(1, 0).EntireRow.Value
        Case Else
            'do nothing
    End Select
 Next i
Application.ScreenUpdating = True

之前：

之后：

另一个 After 选项，如果这更简单的话：

Answer 1

我会怎么做（可能不是那么明显，但应该很快）：

Sub Macro1()
  Dim mainTab As Range, i As Byte, pstRng As Range, pstChk As Range

  With Workbooks("from.xlsm").Sheets("Sheet1") 'get first "Item"-range
    Set mainTab = .Columns(1).Find("Item", .Cells(1, 1), xlValues, 1)
    Set mainTab = .Cells(mainTab.Row, .Columns.Count).End(xlToLeft).Offset(, 1)

    For i = 0 To 2 'build the first table
      .Cells.Find(Array("Invoice", "Invoice Date", "City")(i), .Cells(1, 1), xlValues, 1).Resize(1, 2).Copy
      mainTab.Offset(0, i).PasteSpecial , , , True
    Next

    Set pstRng = mainTab 
    Set mainTab = mainTab.Resize(2, 3) 'the table we will copy later on
    Set pstChk = .Columns(1).Find("Item", , xlValues, 1) 'just to check if the next "Item" is a new one

    While Intersect(pstChk, .Columns(1).FindNext(pstChk.Areas(pstChk.Areas.Count))) Is Nothing 'add all "Item"-Ranges
      Set pstRng = Union(pstRng, .Cells(Columns(1).FindNext(pstChk.Areas(pstChk.Areas.Count)).Row, .Columns.Count).End(xlToLeft).Offset(, 1))
      Set pstChk = Union(pstChk, .Columns(1).FindNext(pstChk.Areas(pstChk.Areas.Count)))
    Wend

    mainTab.Copy pstRng 'copy the first table to all "Item"-Ranges in one step
  End With

  'Copy rows from one workbook to another at each instance of "Item" by "recycling"
  With Workbooks("to.xlsm").Sheets("Sheet2")
    pstChk.Offset(1).EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
  End With

End Sub

最后一部分，将完全替换您的初始宏。

如果有任何问题出现，请直接提问；）