Excel2013 VBA sheet1とsheet2のデータを合成してsheet3を作るには

sheet1に氏名、sheet2にその氏名の人の趣味が入っています。

新たにsheet3を作成して、
氏名１
趣味
氏名１

氏名２
趣味
氏名２

氏名３
趣味
氏名３

氏名４
趣味
氏名４

としたいです。
VBAのコードを教えて下さい。

例えば
①sheet1には
A1；1　B1;阿部　C1;あべ
A2；2　B2;佐藤 C2;さとう
A3；3　B3;山名 C3;やまな
A4；4　B4;山本 C4;やまもと

②sheet2にはその人の趣味が入っています。

A1；1　　B1;釣り　C1;つり
A2；空白　B2;踊り C2;おどり
A3；空白　B3;歌 C3;うた

A4；2　　B4;読書　C4;どくしょ
A5；空白　B5;野球 C5;やきゅう


A6；3　B6;映画鑑賞 C6;えいがかんしょう

A7；4　　B7;釣り　C7;つり
A8；空白　B8;踊り C8;おどり
A9；空白　B9;歌 C9;うた

③sheet3を新に作成して

A1；1　B1;阿部　C1;あべ
A2；空白　　B2;釣り　C2;つり
A3；空白　B3;踊り C3;おどり
A4；空白　B4;歌 C4;うた
A5；空白　B5;阿部　C5;あべ

A6；2　B6;佐藤 C6;さとう
A7；空白　B7;読書　C7;どくしょ
A8；空白　B8;野球 C8;やきゅう
A9；空白　B9;佐藤 C9;さとう

A10；3　B10;山名 C10;やまな
A11；空白　B11;映画鑑賞 C11;えいがかんしょう
A12；空白　B12;山名 C12;やまな

A13；4　B13;山本 C13;やまもと
A14；空白　　B14;釣り　C14;つり
A15；空白　B15;踊り C15;おどり
A16；空白　B16;歌 C16;うた
A17；空白　B17;山本 C17;やまもと



のようにしたいです。

実際、データは、sheet1は419列、sheet2は2563列あります。

No.1 ベストアンサー 回答者： tom04 回答日時： 2016/11/04 23:05

こんばんは！

Sheet3にSheet1のデータを二度表示させるのがイマイチ理解できませんが、
ご質問通りにやってみました。

Sub Sample1()
Dim i As Long, lastRow As Long, myCnt As Long
Dim c As Range, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS2.Rows(1).Insert
wS2.Range("D:D").Insert
With Worksheets("Sheet3")
.Cells.ClearContents
lastRow = wS2.Cells(Rows.Count, "B").End(xlUp).Row
Range(wS2.Cells(2, "D"), wS2.Cells(lastRow, "D")).Formula = "=IF(A2="""",D1,A2)"
For i = 1 To wS1.Cells(Rows.Count, "A").End(xlUp).Row
With .Cells(Rows.Count, "B").End(xlUp).Offset(1)
.Value = wS1.Cells(i, "B")
.Offset(, -1) = wS1.Cells(i, "A")
.Offset(, 1) = wS1.Cells(i, "C")
End With
Set c = wS2.Range("A:A").Find(what:=wS1.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
myCnt = WorksheetFunction.CountIf(wS2.Range("D:D"), wS1.Cells(i, "A"))
.Cells(Rows.Count, "B").End(xlUp).Offset(1).Resize(myCnt, 2).Value = _
c.Offset(, 1).Resize(myCnt, 2).Value
End If
'▼
.Cells(Rows.Count, "B").End(xlUp).Offset(1).Resize(, 2).Value = _
wS1.Cells(i, "B").Resize(, 2).Value
'▲
Next i
.Rows(1).Delete
wS2.Rows(1).Delete
wS2.Range("D:D").Delete
Application.ScreenUpdating = True
.Activate
End With
MsgBox "完了"
End Sub

※　コード内の▼から▲までがもう一度Sheet1のデータを表示させているコードです。
細かい検証はしていませんが、
こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

毎々、お世話になり、有難う御座います。
作るのはお速いですし、いつも通り完璧な結果です。

＞Sheet3にSheet1のデータを二度表示させるのがイマイチ理解できませんが、
英語学習に使う予定です。
１回目に、英文全部を表示させ
２回目以降に、そのパーツを表示させ
最後に、また同じ英文全部を表示させます。
これを１００回以上繰り返し、主要な構文、単語、熟語を覚えようと考えています。

お礼日時：2016/11/05 08:48

No.2 回答者： WindFaller 回答日時： 2016/11/04 23:34

こんばんは。

先程の英文をまとめる内容と同じですね。
さっき作ったもので試してみたら、そのまま出来ましたから。
語学がお得意なら、VBAは、英語よりも遥かに簡単ですから、ご自身で覚えようとすれば、できるようになるはずです。もしくは、Perlなど挑戦してみるのもよいと思います。


'//
Sub ConslidateSentences()
　Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
　Set sh1 = Worksheets("Sheet1")
　Set sh2 = Worksheets("Sheet2")
　Set sh3 = Worksheets("Sheet3")
　Dim x, y
　Dim LastRow As Long
　Dim i As Long, j As Long, k As Long
　
　With sh1
　 LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
　 ReDim x(2, 1 To LastRow)
　 j = 1
　 For i = 1 To LastRow
　　 If .Cells(i, 1).Value <> "" Then
　　　 x(0, j) = .Cells(i, 1).Value
　　　 x(1, j) = .Cells(i, 2).Value
　　　 x(2, j) = .Cells(i, 3).Value
　　　 j = j + 1
　　 End If
　 Next i
　 End With
　 With sh2
　 j = 1
　 LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
　 ReDim y(2, 1 To LastRow)
　 For i = 1 To LastRow
　　　If .Cells(i, 2).Value <> "" Then
　　　 y(0, j) = .Cells(i, 1).Value
　　　 y(1, j) = .Cells(i, 2).Value
　　　 y(2, j) = .Cells(i, 3).Value
　　　 j = j + 1
　　　End If
　 Next i
　 End With
　 Application.ScreenUpdating = False
　 With sh3
　 j = 1: k = 1
　 For i = 1 To UBound(y, 2)
　 If Not IsEmpty(y(0, i)) Then
　　 If i > 1 Then
　　　 .Cells(j, 2).Value = x(1, k)
　　　 .Cells(j, 3).Value = x(2, k)
　　　 j = j + 1: k = k + 1
　　 End If
　　 .Cells(j, 1).Value = x(0, k)
　　 .Cells(j, 2).Value = x(1, k)
　　 .Cells(j, 3).Value = x(2, k)
　　 j = j + 1
　 End If
　　 .Cells(j, 2).Value = y(1, i)
　　 .Cells(j, 3).Value = y(2, i)
　　 j = j + 1
　 Next i
　　　.Cells(j, 2).Value = x(1, k)
　　　.Cells(j, 3).Value = x(2, k)
　 End With
　 Application.ScreenUpdating = True
End Sub

この回答へのお礼

ご回答有難う御座います。

＞VBAは、英語よりも遥かに簡単ですから、ご自身で覚えようとすれば、できるようになるはずです。もしくは、Perlなど挑戦してみるのもよいと思います。

英語は大の苦手です。従いまして、今回、学習ツールを作り勉強しようと思っています。
英語よりもさらに苦手なのが、ソフト作りです。
ソフト作りは、コンピュータの先生から「あなた、頭硬いですね！」って言われた経験を持ち、それ以来苦手コンプレックスを持つようになりました。
この経験により挫折しましたが、チャレンジしたので、出来たソフトの「実行」だけは出来るのです。（悲）

お礼日時：2016/11/05 08:49