Копировать данные из ячейки одного листа в несколько ячеек на другом листе

Question

У меня есть эта база данных, где я храню продажи. Я могу найти конкретные продажи путем фильтрации. Я хотел бы иметь кнопку, которая затем восстанавливает продажи в виде "квитанций" на другом листе.

Это мой код для этого, и он работает в определенной степени:

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

Это берет с первого листа

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

и выводит это на второй лист

123           456
A             D
B             E
USD           GBP
abc           def

Проблема в том, что все продукты хранятся в одной ячейке (столбец E , который соответствует DB_Sheet.Cells(i, 5)). Я хотел бы наклеить продукты по отдельности в разные строки на втором листе, как это

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

Я записал делать это вручную, и вот что у меня есть:

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

Мне нужна помощь в добавлении этого или чего-либо, что дает такие же результаты, в мой первый код.

Answer 1

Намного проще игнорировать записанный макрос и создавать модификацию с нуля.

Из вашего записанного макроса кажется, что ваши продукты разделены запятыми, хотя данные вашего примера показывают обратное.

Итак, если предположить, что это действительно так, то следующий код изменен для "разделения" продуктов на отдельные строки:

'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

Ключ, конечно же, функция Split() которая преобразует строку продуктов, разделенных запятыми, в массив продуктов.

В этом случае достаточно просто вывести этот массив в соответствующий диапазон.

Обратите внимание, что если требуется другой разделитель, просто измените второй аргумент функции Split() .