エクセルの列から行へコピーするＢＶＡ教えて下さい

質問

エクセルのＶＢＡ（マクロ）について、素人なので教えてください。
下記のようなデータ変換を行がある限り変換するＶＢＡマクロです
列1列2列3列4列5列6列7列8
社員1 Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ
社員2 Ｈ Ｉ Ｊ Ｋ
社員3 Ｌ Ｍ
社員4 Ｏ Ｐ Ｑ Ｒ
↓
　 列1列2
社員1 Ａ Ｂ
社員1 Ｃ Ｄ
社員1 Ｅ Ｆ
社員1 Ｇ Ｈ
社員2 Ｈ Ｉ
社員2 Ｉ Ｊ
社員3 Ｌ Ｍ
社員4 Ｏ Ｐ
社員4 Ｑ Ｒ

違うエクセルシートへ行がある限り、コピーを繰り返す。
ＢＶＡの解説付きだと助かります

回答No.4

piroin654 · ベストアンサー

No3の途中のコメントが

'Sheet1の二つのセルの結合データをSheet2にコピペ

になっていましたが、

'Sheet1の二つのセルのデータをそれぞれ別セルにコピペ

にしてください。そのままにしていました。

回答No.3

piroin654

>２列毎　シート２へコピーする方法

No1を少し変形
No1の最後のあたり、

Worksheets("Sheet2").Cells(L2, 2).Value = Worksheets("Sheet1").Cells(p, R2).Value & _
Worksheets("Sheet1").Cells(p, R2 + 1).Value

を

Worksheets("Sheet2").Cells(L2, 2).Value = Worksheets("Sheet1").Cells(p, R2).Value
Worksheets("Sheet2").Cells(L2, 3).Value = Worksheets("Sheet1").Cells(p, R2 + 1).Value

のように二つに分けて、別々のセルにコピペ

Sub test7()
Dim L1 As Long
Dim L2 As Long
Dim R1 As Long
Dim R2 As Long
Dim h As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim x As Long
Dim p As Long

'Sheet1の各列の二つのセルの結合の数ほどSheet1のA列をSheet2にコピペ
L1 = 1
R1 = 1
h = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To h
For j = 1 To (Sheets("Sheet1").Cells(i, Columns.Count).End(xlToLeft).Column - 1) / 2
If Sheets("Sheet1").Cells(i, Columns.Count).End(xlToLeft).Column <> "" Then
Worksheets("Sheet2").Cells(L1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value
L1 = L1 + 1
End If
Next j
Next i

'Sheet1の二つのセルの結合データをSheet2にコピペ
L2 = 1
x = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
For p = 1 To x
For R2 = 2 To Sheets("Sheet1").Cells(p, Columns.Count).End(xlToLeft).Column - 1

Worksheets("Sheet2").Cells(L2, 2).Value = Worksheets("Sheet1").Cells(p, R2).Value
Worksheets("Sheet2").Cells(L2, 3).Value = Worksheets("Sheet1").Cells(p, R2 + 1).Value
R2 = R2 + 1
L2 = L2 + 1
Next R2
Next p
End Sub

なかなか鋭いところを目指していますね。

お礼

早速の回答ありがとうございます
ＶＢＡ勉強していきたいと思います
本当に助かりました

回答No.2

piroin654

＞セルを結合しないで、sheet2へコピーする場合

二通り

(1)　No1との対比で

Sub test5()
Dim L1 As Long
Dim L2 As Long
Dim R1 As Long
Dim R2 As Long
Dim h As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim x As Long
Dim p As Long

'Sheet1の各列のセルの数ほどSheet1のA列をSheet2にコピペ
L1 = 1
R1 = 1
h = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To h
For j = 1 To (Sheets("Sheet1").Cells(i, Columns.Count).End(xlToLeft).Column - 1)
If Sheets("Sheet1").Cells(i, Columns.Count).End(xlToLeft).Column <> "" Then
Worksheets("Sheet2").Cells(L1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value
L1 = L1 + 1
End If
Next j
Next i

'Sheet1のセルのデータをSheet2にコピペ
L2 = 1
x = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
For p = 1 To x
For R2 = 2 To Sheets("Sheet1").Cells(p, Columns.Count).End(xlToLeft).Column

Worksheets("Sheet2").Cells(L2, 2).Value = Worksheets("Sheet1").Cells(p, R2).Value
L2 = L2 + 1
Next R2
Next p
End Sub

(2)　都度データを同時にコピペする方法

Sub test6()
Dim L1 As Long
Dim R1 As Long
Dim h As Long
Dim i As Long
Dim j As Long

'Sheet1の各列のセルの数ほどSheet1のA列をSheet2にコピペ
L1 = 1
R1 = 1
h = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To h
For j = 1 To (Sheets("Sheet1").Cells(i, Columns.Count).End(xlToLeft).Column - 1)
If Sheets("Sheet1").Cells(i, Columns.Count).End(xlToLeft).Column <> "" Then
'Sheet2にSheet1の社員名のコピペ
Worksheets("Sheet2").Cells(L1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value
'セルのデータのコピペ
Worksheets("Sheet2").Cells(L1, 2).Value = Worksheets("Sheet1").Cells(i, j + 1).Value
L1 = L1 + 1
End If
Next j
Next i

End Sub

補足

早速の回答ありがとうございます
上記参考にＶＢＡ勉強したいと思います
大変恐縮ですがもう一点追加で、、、
　　　　列Ａ　列Ｂ
社員１　　Ａ　　Ｂ
社員１　　Ｃ　　Ｄ
社員１　　Ｅ　　Ｆ
社員１　　Ｇ　　Ｈ
社員２　　Ｉ　　Ｊ

というように、２列毎　シート２へコピーする方法ご教授お願いしたいです
時間がある時で結構です

回答No.1

piroin654

解決したでしょうか。
一応、結合するペアが必ず存在することとしています。
データの列が奇数の場合は省いています。
以下を試して意図通りか確かめてみてください。

Sub test4()
Dim L1 As Long
Dim L2 As Long
Dim R1 As Long
Dim R2 As Long
Dim h As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim x As Long
Dim p As Long

'Sheet1の各列の二つのセルの結合の数ほどSheet1のA列をSheet2にコピペ
L1 = 1
R1 = 1
h = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To h
For j = 1 To (Sheets("Sheet1").Cells(i, Columns.Count).End(xlToLeft).Column - 1) / 2
If Sheets("Sheet1").Cells(i, Columns.Count).End(xlToLeft).Column <> "" Then
Worksheets("Sheet2").Cells(L1, 1).Value = Worksheets("Sheet1").Cells(i, 1).Value
L1 = L1 + 1
End If
Next j
Next i

'Sheet1の二つのセルの結合データをSheet2にコピペ
L2 = 1
x = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
For p = 1 To x
For R2 = 2 To Sheets("Sheet1").Cells(p, Columns.Count).End(xlToLeft).Column - 1
Worksheets("Sheet2").Cells(L2, 2).Value = Worksheets("Sheet1").Cells(p, R2).Value & _
Worksheets("Sheet1").Cells(p, R2 + 1).Value
R2 = R2 + 1
L2 = L2 + 1
Next R2
Next p
End Sub

補足

回答ありがとうございます
試してＯＫとなりました。解説も入れて頂き助かりました。
恐縮ですが、もう一点うかがいたいのですが、セルを結合しないで、sheet2へコピーする場合のマクロを教えて頂けないでしょうか
　　　　セル１　セル２
社員１　　Ａ　　　Ｂ
社員１　　Ｃ　　　Ｄ
・
・
・