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

复制一行不同长度，移调它，并粘贴到列的末尾

1 个答案: