将Excel中的数据从列复制到VBA行

我有一点与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行为时间，1行为16个通道）。 我试图把它变成一个步长为18的循环。这可能吗？ 我很好循环，但我从来没有做过复制和粘贴单元格值的循环

Answer 1

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

如果你的数据集的大小发生了很大的变化，你将需要包含一些逻辑来调整循环variables和数组大小的声明。 如果是这样的话，让我知道，我会弄清楚如何做到这一点，并发布编辑。

 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 

编辑 – >我认为这是你阅读你的编辑后，你正在寻找的

 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 

现在这个工作的关键是知道在数据转储之后有多less组数据。 您可能需要包含用于检测的逻辑或调整称为numberDataGroups的常量以反映您拥有多less个组。 注意：我使用了一种类似的技术来遍历以Row Major格式存储数据的数组。

Answer 2

试试这个代码：

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

另外检查这个链接： 在VBA中调换一个范围

Answer 3

使用“复制”，然后select“粘贴特殊+移调”将列变成行：
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

Answer 4

尝试这个：

 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 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