关于vba：复制长度可变的一行，将其转置，然后粘贴到列的末尾


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

我正在处理一个宏，以将不同数量的单元格复制到一行中，转置并粘贴到另一张工作表中，在下一列的空白单元格中。然后的想法是将每个转置项与它所在的行中的ID相匹配。 ID列中的行数也将有所不同。

在下面的示例中，ID 1与Co D和Co R相关联。转置会导致需要将ID 1复制到与目标相邻的两个单元中。我创建的此示例将它们放在同一张纸上，但是对于代码本身，它将在另一张纸上。

enter

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
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

编辑：您可以在下面的答案中看到吉普车的解决方案，可以轻松地工作。确保源数据中没有错误，否则您可能会遇到运行时错误13.

相关讨论

在将值传递回工作表之前，请尝试在二维数组中转置。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
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

enter

相关讨论