Copy data from one sheet's cell to multiple cells in another sheet

Question

I have this database where I store sales. I can find particular sales by filtering. I would like to have a button that then regenerates the sales as "receipts" in another sheet.

This is my code for that and it works to a certain degree:

Dim i As Long
Dim col As Integer
Dim DB_Sheet, Rec_Sheet As Object

Set DB_Sheet = ThisWorkbook.Worksheets("Sheet3")
Set Rec_Sheet = ThisWorkbook.Worksheets("Sheet2")
col = 1
For i = 2 To DB_Sheet.Range("A" & Rows.Count).End(xlUp).Row
        If DB_Sheet.Rows(i).Hidden = False Then
            Rec_Sheet.Cells(1, col) = DB_Sheet.Cells(i, 7)
            Rec_Sheet.Cells(2, col) = DB_Sheet.Cells(i, 8)
            Rec_Sheet.Cells(3, col) = DB_Sheet.Cells(i, 6)
            Rec_Sheet.Cells(4, col) = DB_Sheet.Cells(i, 9)
            Rec_Sheet.Cells(5, col) = DB_Sheet.Cells(i, 5)
        col = col + 1
        End If
Next i

It takes this from the first sheet

BUYER  SELLER  DATE  PRODUCTS  CURRENCY
A      B       123   abc        USD
D      E       456   def        GBP

and outputs this on the second sheet

123           456
A             D
B             E
USD           GBP
abc           def

The problem is that the products are all stored in one cell (column E, which corresponds to DB_Sheet.Cells(i, 5)). I would like to paste the products individually in different rows on the second sheet, like this

123           456
A             D
B             E
USD           GBP
a             d
b             e
c             f

I recorded doing it manually and this is what I have:

Range("E2").Select
Selection.TextToColumns Destination:=Range("S2"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
    Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1)), TrailingMinusNumbers:=True
Range("S2:AB2").Select
Selection.Copy
Range("S3").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
Range("S2:AB2").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp

I need help adding this, or anything that achieves the same results, to my first code.

Answer 1

It's much simpler to ignore the recorded macro and build the modification from scratch.

From your recorded macro it looks like your products are comma delimited, even though your example data shows otherwise.

So, assuming that this is indeed the case, the following is your code modified to "split" the products into separate rows:

'v0.1.0
Dim i As Long
Dim col As Integer
Dim DB_Sheet, Rec_Sheet As Object

Set DB_Sheet = ThisWorkbook.Worksheets("Sheet3")
Set Rec_Sheet = ThisWorkbook.Worksheets("Sheet2")
col = 1
For i = 2 To DB_Sheet.Range("A" & Rows.Count).End(xlUp).Row
    If DB_Sheet.Rows(i).Hidden = False Then
        Rec_Sheet.Cells(1, col) = DB_Sheet.Cells(i, 7)
        Rec_Sheet.Cells(2, col) = DB_Sheet.Cells(i, 8)
        Rec_Sheet.Cells(3, col) = DB_Sheet.Cells(i, 6)
        Rec_Sheet.Cells(4, col) = DB_Sheet.Cells(i, 9)
        Dim varProducts As Variant
        varProducts = Split(DB_Sheet.Cells(i, 5).Value2, ",")
        Rec_Sheet.Cells(5, col).Resize(RowSize:=UBound(varProducts) - LBound(varProducts) + 1).Value2 _
        = WorksheetFunction.Transpose(varProducts)
        col = col + 1
    End If
Next i

The key is, of course, the Split() function that converts the string of comma delimited products to an array of products.

It is then a simple matter of outputting that array to the appropriate range.

Note that if a different delimiter is required, just change the second argument of the Split() function.