复制一个不同长度的行，转置它，并粘贴在列的末尾

我正在处理一个macros，将不同数量的单元格复制到一行，转置并粘贴到另一个表单中，列中的下一个空单元格中。 然后这个想法是将每个转置的项目与来自它的行的ID进行匹配。 ID列中的行数也会有所不同。

查看下面的例子，ID 1与Co D和Co R相关联。转置将需要将ID 1复制到与目的地相邻的两个单元中。 我创build的这个例子使它们在同一张纸上，但是对于代码本身，它将在不同的纸上。

问题出现在复制范围转置。 我似乎无法弄清楚如何抓整行。 macros正确地粘贴在目的地的下一个可用的单元格的值，但我现在的代码版本只复制行中的最后一个结果，而不是我的意图的整个行。 我甚至没有得到在目标列中匹配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的解决scheme，您可以在下面的答案中看到作品游泳。 确保源数据中没有错误，否则可能会出现运行时错误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