複製一行不同的長度，轉置它，並粘貼在列的末尾

Question

我正在處理一個宏，將不同數目的單元格複製到一行，轉置並粘貼到另一個表單中，在下一個空一列中的單元格。然後這個想法是將每個轉置項目與來自它的行的ID進行匹配。 ID列中的行數也會有所不同。

查看下面的示例，ID 1與Co D和Co R相關聯。轉置將創建需要將ID 1複製到與目標相鄰的兩個單元中。我創建的這個例子將它們放在同一張紙上，但對於代碼本身，它將放在另一張紙上。

的問題出現在複製的範圍內進行轉置。我似乎無法弄清楚如何抓住整排。宏正確地將值粘貼到目標中的下一個可用單元格中，但現在我所擁有的代碼版本只複製行中的最後一個結果，而不是整個行的意圖。我甚至沒有得到在目標列中將ID與Co匹配的部分，但我已經對此感到厭煩。我的代碼如下：

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 

編輯：Jeeped的解決方案，您可以在下面的答案中看到作品游泳。確保源數據中沒有錯誤，否則可能會出現運行時錯誤13.

Answer 1

在將值傳遞迴工作表之前，嘗試在二維數組中進行轉置。

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