复制一行不同长度的行，转置它，然后粘贴到列的末尾

Question

我正在开发一个宏，将不同数量的单元格复制到一行，转置并粘贴到不同的 sheet，在一列的下一个空单元格中。然后我们的想法是将每个转置项目与其来源的行中的 ID 进行匹配。 ID 列中的行数也会有所不同。

查看下面的示例，ID 1 与 Co D 和 Co R 相关联。转置将需要将 ID 1 复制到与目标相邻的两个单元格中。我创建的这个示例将它们放在相同的 sheet 上，但对于代码本身，它将位于不同的 sheet.

上

复制要转置的范围时出现问题。我似乎无法弄清楚如何抓住整行。宏正确地将值粘贴到目标中的下一个可用单元格中，但我现在拥有的代码版本仅复制行中的最后一个结果，而不是我想要的整行。我什至还没有完成将 ID 与 Destination 列中的 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

复制一行不同长度的行，转置它，然后粘贴到列的末尾

copy a row of varied length, transpose it, and paste at the end of a column

excel

vba

transpose