Copie dados da célula de uma planilha para várias células em outra planilha

Question

Eu tenho esse banco de dados onde armazeno vendas. Eu posso encontrar vendas específicas por filtragem. Eu gostaria de ter um botão que regenere as vendas como "recibos" em outra planilha.

Este é o meu código para isso e funciona até certo ponto:

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

Leva isso da primeira folha

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

e gera isso na segunda planilha

123           456
A             D
B             E
USD           GBP
abc           def

O problema é que os produtos são todos armazenados em uma célula (coluna E , que corresponde a DB_Sheet.Cells(i, 5) ). Eu gostaria de colar os produtos individualmente em linhas diferentes na segunda folha, como esta

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

Eu gravei fazendo isso manualmente e é isso que eu tenho:

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

Preciso de ajuda para adicionar isso ou qualquer coisa que alcance os mesmos resultados no meu primeiro código.

    

Answer 1

É muito mais simples ignorar a macro gravada e criar a modificação a partir do zero.

Na sua macro gravada, parece que seus produtos são delimitados por vírgulas, mesmo que seus dados de exemplo mostrem o contrário.

Portanto, supondo que esse seja realmente o caso, o código a seguir é modificado para "dividir" os produtos em linhas separadas:

'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

A chave é, naturalmente, a função Split() que converte a string de produtos delimitados por vírgulas em uma matriz de produtos.

É então uma simples questão de produzir esse array para o intervalo apropriado.

Observe que, se um delimitador diferente for necessário, apenas altere o segundo argumento da função Split() .