Skopiuj dane z komórki jednego arkusza do wielu komórek w innym arkuszu

Mam tę bazę danych, w której przechowuję sprzedaż. Mogę znaleźć określoną sprzedaż, filtrując. Chciałbym mieć przycisk, który następnie regeneruje sprzedaż jako „paragony” w innym arkuszu.

To jest mój kod do tego i działa do pewnego stopnia:

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

Pobiera to z pierwszego arkusza

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

i wyprowadza to na drugim arkuszu

123           456
A             D
B             E
USD           GBP
abc           def

Problem polega na tym, że wszystkie produkty są przechowywane w jednej komórce ( Eodpowiadającej kolumnie DB_Sheet.Cells(i, 5)). Chciałbym wkleić produkty indywidualnie w różnych rzędach na drugim arkuszu, w ten sposób

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

Nagrałem robiąc to ręcznie i oto co mam:

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

Potrzebuję pomocy w dodaniu tego, lub czegokolwiek, co osiągnie te same wyniki, do mojego pierwszego kodu.

— użytkownik1234
źródło

O wiele łatwiej jest zignorować zarejestrowane makro i zbudować modyfikację od zera.

Z zarejestrowanego makra wygląda na to, że twoje produkty są rozdzielane przecinkami, nawet jeśli twoje przykładowe dane pokazują inaczej.

Zakładając, że tak właśnie jest, następujący kod jest modyfikowany w celu „podzielenia” produktów na osobne wiersze:

'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

Kluczem jest oczywiście Split()funkcja konwertująca ciąg produktów rozdzielanych przecinkami na szereg produktów.

Jest to zatem prosta kwestia przekazania tej tablicy do odpowiedniego zakresu.

Zauważ, że jeśli wymagany jest inny ogranicznik, wystarczy zmienić drugi argument Split()funkcji.

— robinCTS
źródło