复制列（垂直）选择以反向粘贴行（水平）

Posted 2021-03-27

我希望将列数据转换为Row（一个接一个）。

我使用下面的代码，但由于数据有空格，因此无效。

Sub RUN_MACRO()

Range("A1").Select
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlDown)).Select

Selection.Copy
Range("J2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
 Range("A6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("J3").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True
Range("A1").Select
End Sub

以下是输入和输出的屏幕截图。 输入数据

寻找以下输出：

答案

即使您的某个字段中没有数据，或者您不小心留下了更多空格，这也会有效。

Sub test3()

Dim rng As Range

Application.ScreenUpdating = False
Set rng = Columns("A:A").SpecialCells(xlCellTypeConstants)
    For i = 1 To rng.Areas.Count
        rng.Areas(i).Copy
        Range("C" & i + 1).PasteSpecial xlPasteAll, Transpose:=True
    Next i
Set rng = Nothing
Application.ScreenUpdating = True

End Sub

另一答案

假设包含数据的工作表称为Sheet1，因为您没有提供大量有用的信息。

Sub TransposeData()

Dim ws1 As Worksheet
Set ws1 = Worksheets("Sheet1")

Dim DataRange As Range
Dim DataCell As Range
Dim x As Integer
Dim y As Integer
Dim LastRow As Long
x = 0
y = 0

With ws1
LastRow = .Cells.Find(What:="*", After:=.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
End With

Set DataRange = ws1.Range("A1:A" & LastRow)
For Each DataCell In DataRange
    If DataCell.Value <> "" Then
        ws1.Range("C2").Offset(y, x).Value = DataCell.Value
        x = x + 1
        If x = 4 Then
            x = 0
            y = y + 1
        End If
    End If
Next DataCell

End Sub

这应该可以解决问题。编辑动态操作。