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

Question

我有一些代码将通过我的工作表并找到A列中具有值＆＃34; Item＆＃34;的每个单元格。然后，它将直接复制具有值＆＃34;项目的单元格下方的整行。＆＃34;

我想做的是：

• 浏览工作表并找到＆＃34;发票的每个实例，＆＃34; ＆＃34;发票日期，＆＃34;和＆＃34; City＆＃34;
• 找到这些细胞后，立即将这些细胞和细胞复制到右侧
• 然后通过并查找A列中具有值＆＃34; Item＆＃34;的每个单元格，并在下一个空白列中粘贴（使用转置）两个复制的单元格行。
• 然后我会复制＆＃34;项目＆＃34;我已经在下面写了代码

这是我到目前为止的代码，以及一些我想做的照片。

请耐心等待，因为我刚开始学习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

之前：

后：

另一个选项后，如果这更简单：

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

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

如果弹出任何问题，请询问;）