skopírujte rad rôznej dĺžky, preveďte ho a vložte na koniec stĺpca - excel, vba, excel-vba, transponujte

Pracujem na makro na kopírovanie rôzneho číslabuniek do radu, transponovať a vložiť do iného listu v ďalšej prázdnej bunke v stĺpci. Následne ide o to, aby každá transponovaná položka zodpovedala identifikačnému ID z riadku, z ktorého pochádza. Počet riadkov v stĺpci ID sa tiež bude líšiť.

Pri pohľade na príklad nižšie je priradený ID 1s Co D a Co R. Transpozícia by vytvorila potrebu, aby ID 1 bol kopírovaný do dvoch buniek vedľa cieľa. Tento príklad, ktorý som vytvoril, ich má na rovnakom hárku, ale pre samotný kód bude na inom hárku.

Problém sa zobrazí pri kopírovaní rozsahutransponovaná. Nemôžem zistiť, ako uchopiť celý riadok. Makro správne vložiť hodnotu do ďalšej dostupnej bunky v cieľovom umiestnení, ale verzia kódu, ktorú teraz kopírujem len posledný výsledok v riadku a nie celý riadok, ktorý je mojou zámerou, som sa ani nedostal do časti zodpovedajúcej identifikačnému číslu do stĺpca Co v stĺpci Destination, ale už sa to už obávam. Kód, ktorý mám, je nasledujúci;

Sub Testing()

Dim TearS As Worksheet:         Set TearS = Worksheets(1)
Dim FeeS As Worksheet:          Set FeeS = Worksheets(2)
Dim EntryS As Worksheet:        Set EntryS = Worksheets(3)
Dim Stage2 As Worksheet:        Set Stage2 = Worksheets(4)
Dim Stage3 As Worksheet:        Set Stage3 = Worksheets(5)

Dim Bbg As Range:               Set Bbg = EntryS.Range("F4:T199")
Dim TDest As Range:             Set TDest = Stage2.Range("F5:T200")
Dim DateA As Range:         Set DateA = Stage2.Range("G5:G200")
Dim DateB As Range:         Set DateB = TearS.Range("E5:E200")
Dim DesA As Range:          Set DesA = Stage2.Range("J5:J200")
Dim DesB As Range:          Set DesB = TearS.Range("O5:O200")
Dim DesC As Range:          Set DesC = Stage3.Range("C5:C200")
Dim CpnMatA As Range:       Set CpnMatA = Stage2.Range("Y5:Y200")
Dim CpnMatB As Range:       Set CpnMatB = TearS.Range("P5:P500")
Dim SettA As Range:         Set SettA = Stage2.Range("I5:I200")
Dim SettB As Range:         Set SettB = TearS.Range("Q5:Q200")
Dim MinA As Range:          Set MinA = Stage2.Range("AA5:AA200")
Dim MinB As Range:          Set MinB = Stage3.Range("D5:D200")
Dim MWOB As Range:          Set MWOB = TearS.Range("N5:N200")

Dim Cel As Range

For Each Cel In DesC
If IsEmpty(Cel) = False Then
Cel.Offset(0, 1).End(xlToRight).Copy
TearS.Range("N3").End(xlDown).Offset(1).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True

End If
Next Cel

End Sub

Upraviť: Jeeped riešenie, ktoré môžete vidieť v nižšie uvedenej odpovedi, pracuje v plávaní. Uistite sa, že v zdrojových dátach nie sú žiadne chyby, alebo sa môže vyskytnúť chyba spustenia 13.

odpovede:

Skúste vykonať transpozíciu v rámci 2-D poľa predtým, ako prejdete hodnoty do pracovného hárka.

Sub rewrite()
Dim lr As Long, a As Long, b As Long, val As Variant, vals As Variant

With Worksheets("sheet6")
.Range("F:G").Clear
lr = Application.Max(.Cells(.Rows.Count, "B").End(xlUp).Row, _
.Cells(.Rows.Count, "C").End(xlUp).Row, _
.Cells(.Rows.Count, "D").End(xlUp).Row, _
.Cells(.Rows.Count, "E").End(xlUp).Row)
vals = .Range(.Cells(2, "A"), .Cells(lr, "E")).Value2
For a = LBound(vals, 1) To UBound(vals, 1)
ReDim val(1 To UBound(vals, 2), 1 To 2)
For b = LBound(val, 1) To UBound(val, 1) - 1
If CBool(Len(vals(a, b + 1))) Then
val(b, 1) = vals(a, 1)
val(b, 2) = vals(a, b + 1)
End If
Next b
.Cells(.Rows.Count, "F").End(xlUp).Offset(1, 0).Resize(UBound(val, 1), UBound(val, 2)) = val
Next a
End With
End Sub