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

Question

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

我想做的是:

浏览工作表并找到“发票”、“发票日期”和“城市”

的每个实例

找到这些单元格后，将这些单元格和立即复制到其右侧的单元格

然后遍历并找到 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

之前:



之后:



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

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

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

如果有任何问题弹出，请问;)