kopieren Sie eine Reihe unterschiedlicher Länge, transponieren Sie es und fügen Sie am Ende einer Spalte

Question

Ich arbeite an einem Makro, um eine variierte Anzahl von Zellen in eine Zeile zu kopieren, zu transponieren und in ein anderes Blatt, in der nächsten leeren einfügen Zelle in einer Spalte. Dann besteht die Idee darin, jedes transponierte Element mit der ID aus der Zeile zu vergleichen, aus der es stammt. Die Anzahl der Zeilen in der ID-Spalte variiert ebenfalls.

Im folgenden Beispiel wird ID 1 Co D und Co R zugeordnet. Das Transponieren würde die Notwendigkeit verursachen, ID 1 in die zwei Zellen neben dem Ziel zu kopieren. Dieses Beispiel, das ich erstellt habe, hat sie auf demselben Blatt, aber für den Code selbst wird es auf einem anderen Blatt sein.

Das Problem scheint in Kopieren der Bereich umgesetzt werden. Ich kann mir nicht vorstellen, wie ich die ganze Reihe ergattern soll. Das Makro fügt den Wert in der nächsten verfügbaren Zelle im Ziel korrekt ein, aber die Version des Codes, die ich jetzt habe, kopiert nur das letzte Ergebnis in der Zeile und nicht die ganze Zeile, die meine Absicht ist. Ich bin noch nicht einmal dazu gekommen, die ID der Co in der Destination-Spalte zuzuordnen, aber ich fürchte mich schon davor. Der Code, den ich habe, ist wie folgt;

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 

Edit: Jeepeds Lösung, die Sie in der Antwort unten sehen können, funktioniert schwimmend. Stellen Sie sicher, dass keine Fehler in den Quelldaten vorhanden sind, oder dass ein Laufzeitfehler auftritt.

Answer 1

Versuchen Sie, in einem 2-D-Array zu transponieren, bevor Sie die Werte an das Arbeitsblatt zurückübertragen.

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