使用VBA将Excel数据从列复制到行

Question

我对VBA有一点经验，我真的很感激这个问题的任何帮助。从基本的意义上讲，我需要将表1中的2列数据转换为表2中的数据行。

目前在Excel中看起来像这样：

我需要它看起来像这样：

我已经编写了代码将标题转移到表2，它工作正常。我只是在以正确的格式传输实际值时遇到问题。现在，我的代码正文是

ws.Range("B3").Copy
ws2.Range("C2").PasteSpecial xlPasteValues

ws.Range("B4").Copy
ws2.Range("D2").PasteSpecial xlPasteValues

ws.Range("B5").Copy
ws2.Range("E2").PasteSpecial xlPasteValues

ws.Range("B6").Copy
ws2.Range("F2").PasteSpecial xlPasteValues

继续。但是，这真的不行，因为我正在处理的实际文档有数万个数据点。我知道有一种方法可以自动化这个过程，但是我尝试过的所有事情都没有做任何事情或者给出了错误1004.

对此有任何帮助将不胜感激!!

编辑：有数百个小部分数据，每个18行长（帧＃为1行，时间为1行，16个通道各为1行）。我试图让它进入一个步长为18的循环。这可能吗？我对循环很好，但我从来没有完成复制和粘贴单元格值的循环

Answer 1

试试这段代码：

Dim X() As Variant
Dim Y() As Variant
X = ActiveSheet.Range("YourRange").Value
Y = Application.WorksheetFunction.Transpose(X)

另请查看此链接：Transpose a range in VBA

Answer 2

使用“复制”，然后选择“粘贴特殊+转置”将列转换为行：
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

Answer 3

试试这个：

Sub TansposeRange()
 Dim InRange As Range
 Dim OutRange As Range
 Dim i As Long

 Set InRange = Sheet1.Range("B3:B10002")
 Set OutRange = Sheet2.Range("C2")

 InRange.Worksheet.Activate
 InRange.Select
 Selection.Copy

 OutRange.Worksheet.Activate
 OutRange.Select

 Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

End Sub

Answer 4

此方法利用循环和数组来传输数据。它不是最动态的方法，但它完成了工作。所有循环都使用现有常量，因此如果您的数据集发生更改，您可以调整常量，它应该运行得很好。确保调整工作表名称以匹配您在Excel文档中使用的名称。实际上，这样做是将数据加载到数组中并将其转换到另一个工作表上。

如果您的数据集大小发生了很大变化，您将需要包含一些逻辑来调整循环变量和数组大小声明。如果是这种情况，请告诉我，我会弄清楚如何做并发布修改。

Sub moveTimeData()

Set source = ThisWorkbook.Sheets("RawData")
Set dest = ThisWorkbook.Sheets("TransposeSheet")

Const dataSetSize = 15

Const row15Start = 3
Const row15End = 18
Const row30Start = 21
Const row30End = 36

Const colStart = 2

Const destColStart = 2
Const dest15RowStart = 2
Const dest30RowStart = 3

Dim time15Array() As Integer
Dim time30Array() As Integer
ReDim time15Array(0 To dataSetSize)
ReDim time30Array(0 To dataSetSize)

Dim X As Integer
Dim Y As Integer
Dim c As Integer
c = 0

For X = row15Start To row15End
    time15Array(c) = source.Cells(X, colStart).Value
    c = c + 1
Next X

c = 0
For X = row30Start To row30End
    time30Array(c) = source.Cells(X, colStart).Value
    c = c + 1
Next X

For X = 0 To dataSetSize
    dest.Cells(dest15RowStart, X + destColStart).Value = time15Array(X)
Next X

For X = 0 To dataSetSize
    dest.Cells(dest30RowStart, X + destColStart).Value = time30Array(X)
Next X

End Sub

<强>编辑 - ＆GT;我认为这是您在阅读编辑后所寻找的内容

Sub moveTimeData()

Set source = ThisWorkbook.Sheets("RawData")
Set dest = ThisWorkbook.Sheets("TransposeSheet")

Const numberDataGroups = 4
Const dataSetSize = 15
Const stepSize = 18

Const sourceRowStart = 3

Const sourceColStart = 2

Const destColStart = 2
Const destRowStart = 2



Dim X As Integer
Dim Y As Integer
Dim currentRow As Integer
currentRow = destRowStart



For X = 0 To numberDataGroups
    For Y = 0 To dataSetSize
        dest.Cells(currentRow, Y + destColStart).Value = source.Cells((X * stepSize) + (Y    + sourceRowStart), sourceColStart)
    Next Y
    currentRow = currentRow + 1
Next X


End Sub

现在，这项工作的关键是了解数据转储后您要处理的数据组数量。您需要包含用于检测的逻辑或调整名为numberDataGroups的常量以反映您拥有的组数。注意：我利用类似的技术遍历那些以Row Major格式存储数据的数组。

Answer 5

这是一种使用循环的方法，这里用步骤2来说明

请注意，您必须精确指定OutRange的正确大小（此处NTR2是第二行的10001单元格）。

Sub TansposeRange()
 Dim InRange As Range
 Dim OutRange As Range
 Dim i As Long

 Set InRange = Sheet1.Range("B3:B10002")
 Set OutRange = Sheet2.Range("C2:NTR2")

 For i = 1 To 10000 Step 2
  OutRange.Cells(1, i) = InRange.Cells(i, 1)
 Next i

End Sub

Answer 6

    'The following code is working OK
    Sub TansposeRange()
    '
    ' Transpose Macro
    '
    Dim wSht1 As Worksheet
    Dim rng1 As Range
    Dim straddress As String
    Set wSht1 = ActiveSheet

    On Error Resume Next
    Set rng1 = Application.InputBox(Prompt:="Select Columns or Rows to transpose", _
                                   Title:="TRANSPOSE", Type:=8)
    If rng1 Is Nothing Then
        MsgBox ("User cancelled!")
        Exit Sub
    End If
    straddress = InputBox(Prompt:="Full cell Address as Sheet2!A1", _
          Title:="ENTER Full Address", Default:="Sheet1!A1")
    If straddress = vbNullString Then
         MsgBox ("User cancelled!")
         Exit Sub
    End If      

    Application.ScreenUpdating = False
    rng1.Select
    rng1.Copy

    On Error GoTo 0

    'MsgBox straddress
    Range(straddress).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.ScreenUpdating = True
    End Sub