將Excel數據從列複製到使用VBA的行中

Question

我對VBA有一點經驗，我非常感謝有關此問題的任何幫助。在基本的意義上說，我需要的數據的2列轉換在表1數據行的紙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文檔中使用的名稱。實際上，這是將數據加載到數組中並將其轉換到另一個工作表上。

如果您的數據集大小發生了相當大的變化，您將需要包含一些邏輯來調整循環變量和數組大小聲明。如果是這樣的話，讓我知道，我會弄清楚如何做到這一點，併發布編輯。

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 

現在的關鍵是這個工作後，找什麼是知道如何許多數據組你正在處理後數據轉儲。您可能需要包含用於檢測的邏輯或調整稱爲numberDataGroups的常量以反映您擁有多少個組。注意：我使用了一種類似的技術來遍歷以Row Major格式存儲數據的數組。

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

試試這個代碼：

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

還檢查了此鏈接：Transpose a range in VBA

Answer 5

這是一個辦法做到這一點使用一個循環，在這裏與你必須指定outrange：超出恰恰是正確的大小爲2

通知了一步所示（這裏NTR2是10001的第2行的單元格） 。

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