Excel VBA - Copy certain cells and paste next to other cells in same worksheet

Question

I have some code that will go through my sheet and find every cell in column A that has the value "Item". Then, it will copy the entire row directly beneath the cell that has the value "Item."

What I'd like to do is this:

Go through the sheet and find each instance of "Invoice," "Invoice Date," and "City"
When those cells are found, copy those cells and the cells immediately to their right
Then go through and find every cell in column A that has the value "Item", and paste (with transpose) the two copied cells at the next blank column of that row.
Then I'll copy the row beneath "Item" with the code I've already written below

Here is the code I have so far, along with a few pictures of what I'd like to do.

Please bear with me as I just started learning VBA yesterday and I'm very new. I know how to do some smaller parts of this, but the whole process is still hazy to me. Any advice appreciated. Thanks!

' 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

Before:

After:

Another After Option, if this is simpler:

will "Invoice", "Invoice Date" and "City" always be in a small table like in your pictures? or can they also be separated? — Dirk Reichel
@DirkReichel They're always in the same column. I think the format is actually "Item" followed immediately by "Invoice Date" then a blank row and then "City". — pez
@DirkReichel Apologies, third picture had a typo. Please see updated picture. — pez
OK, thanks... just to clarify: there is only one "block" like this and you want it (always the same) transposed after each "Item"-line, is that correct? :) — Dirk Reichel
Yes, correct, that block will only show up once in the sheet, and it should transposed at the end of the row beneath each "Item" line. — pez

Dirk Reichel Dirk Reichel · Accepted Answer · 2016-06-25T18:11:51

Just how I would do it (it may be not that obvious, but should be fast):

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

The last part, would replace your initial macro completely.

If any questions pop up, just ask ;)

Excel VBA - Copy certain cells and paste next to other cells in same worksheet

1 Answers