skopiuj wiersz o różnej długości, transponuj go i wklej na końcu kolumny - excel, vba, excel-vba, transpose

Pracuję nad makrem, aby skopiować zróżnicowaną liczbękomórek do wiersza, transponuj i wklej do innego arkusza, w następnej pustej komórce w kolumnie. Pomysł polega na dopasowaniu każdej transponowanej pozycji do identyfikatora z wiersza, z którego pochodzi. Liczba wierszy w kolumnie ID również będzie się różnić.

Patrząc na poniższy przykład, identyfikator 1 jest powiązanyz Co D i Co R. Transpozycja spowodowałaby konieczność skopiowania ID 1 do dwóch komórek sąsiadujących z miejscem docelowym. Ten przykład, który utworzyłem, ma je na tym samym arkuszu, ale dla samego kodu będzie znajdował się na innym arkuszu.

Problem pojawia się podczas kopiowania zakresutransponowane. Nie potrafię odgadnąć, jak pobrać cały wiersz. Makro poprawnie wkleja wartość do następnej dostępnej komórki w miejscu docelowym, ale wersja kodu, którą mam teraz, kopiuje tylko ostatni wynik w wierszu, a nie cały rząd, który jest moim zamiarem. Nawet nie dotarłem do części dopasowania identyfikatora do kolumny Co in the Destination, ale już się tego boję. Kod, który mam, jest następujący;

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

Edytuj: Rozwiązanie firmy Jeeped, które można zobaczyć w poniższej odpowiedzi, działa płynnie. Upewnij się, że nie ma błędów w danych źródłowych lub możesz uzyskać błąd czasu wykonywania 13.

Odpowiedzi:

Spróbuj przenieść transpozycję w tablicy 2D przed przekazaniem wartości z powrotem do arkusza roboczego.

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