【エクセル】複数行のデータを２列に整形（VBAで対応したいです）

Sheet1にある複数行のデータを
別シート（仮にSheet2）へ２列に整形したいと思っています。

画像のようなSheet1データを、Sheet2データのようにしたいです。（実際のデータ数は1万行ほどあります。）

VBAで対応できると幸いです。
どうぞ、よろしくお願いします。

No.2 ベストアンサー 回答者： soixante 回答日時： 2015/10/31 10:59

こんな形でやってみました。

'--------------------------------------------------------
Option Explicit

Sub Tenki2()

'変数宣言とセット
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim r As Long, k As Long
Dim Midashi(4) As Variant, myData(4) As Variant
Dim TgtRow As Long

Set Ws1 = Worksheets(1)
Set Ws2 = Worksheets(2)

TgtRow = 2 'Sheet2の転記先は2行目から開始


'見出し行を格納
For k = 0 To 4
Midashi(k) = Ws1.Cells(1, k + 1)
Next k


Application.ScreenUpdating = False

'Sheet1のデータを上から下にループ
With Ws1
r = 2
Do While .Cells(r, 1).Value <> ""
For k = 0 To 4 'その行のデータをmyDataに格納
myData(k) = .Cells(r, k + 1)
Next k

For k = LBound(myData) To UBound(myData) 'Sheet2で、縦に転記
Ws2.Cells(TgtRow + k, 1).Value = Midashi(k)
Ws2.Cells(TgtRow + k, 2).Value = myData(k)
Next k

TgtRow = Ws2.Cells(Rows.Count, 1).End(xlUp).Row + 2 '次の転記開始行

r = r + 1

If r Mod 500 = 0 Then Application.StatusBar = r

Loop
End With

Application.StatusBar = ""
Application.ScreenUpdating = True
Ws2.Select

MsgBox "End."

End Sub

No.3 回答者： CoalTar 回答日時： 2015/10/31 11:09

ほとんど数式(^^;

Sub Sheet2へ転記する()
Application.ScreenUpdating = False
　 Dim 最終行 As Long
　 最終行 = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
　 Worksheets("Sheet2").Range("A:B").ClearContents
　 With Worksheets("Sheet2").Range("A2:A" & 最終行 * 6 - 6)
　 　 .FormulaR1C1 = "=IF(MOD(ROW(),6)=1,"""",INDEX(Sheet1!R1,MOD(ROW()-2,6)+1))"
　 　.Value = .Value
　 　.Offset(, 1).FormulaR1C1 = _
　 　 "=IF(RC[-1]="""","""",INDEX(Sheet1!C[-1]:C[3],(ROW()-2)/6+2,MOD(ROW()-2,6)+1))"
　 　 .Offset(, 1).Value = .Offset(, 1).Value
　 End With
Application.ScreenUpdating = True
End Sub

No.1 回答者： tom04 回答日時： 2015/10/31 10:49

こんにちは！

一例です。
標準モジュールにしてください。

Sub Sample1()
Dim lastRow As Long, wS As Worksheet, myRng As Range
Set wS = Worksheets("Sheet1")
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
With Worksheets("Sheet2")
.Range("A:B").ClearContents
Range(.Cells(2, "A"), .Cells((lastRow - 1) * 6, "A")).Formula = _
"=INDEX(Sheet1!A$1:F$1,,IF(MOD(ROW(C7),6)=0,"""",MOD(ROW(C7),6)))"
Range(.Cells(2, "B"), .Cells((lastRow - 1) * 6, "B")).Formula = _
"=INDEX(Sheet1!A:F,INT(ROW(A1)/6)+2,MOD(ROW(A1),6))"
With .Range("A:B")
.Value = .Value
End With
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A1") = "ダミー"
.Range("A1").AutoFilter field:=1, Criteria1:="#VALUE!"
Range(.Cells(2, "A"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).ClearContents
.AutoFilterMode = False
.Range("A1").ClearContents
End With
Application.ScreenUpdating = True
MsgBox "完了"

※　1行ずつループすると相当の時間を要すると思いますので、
別の方法でやってみました。

こんな感じではどうでしょうか？m(_ _)m