エクセルでシートの（結合）マージ

質問

はじめて質問をさせていただきます。
エクセルのシートを（結合）マージをしたいと思います。
たとえばシート１とシート２共にあるデータ、シート１のみのデータ、シート２のみのデータを区別したいのですが、そしてなおかつできればその結果をシート３に表示する。ということができればと思います。
たとえば、シート１・２（Ａ列に比較項目　Ｂ列以降は他の項目）とし
シート１　　　　　　　　　　 シート２
A123,12345,2345 　　　　　 A123,12345,2345
A234,23456,3456　　　　　 A345,34567,4567
A345,34567,4567 　　　　　 A456,45678,5678
これをシート３に
A123,12345,2345,A123,12345,2345 （両方）
A234,23456,3456, , , （シート１のみ）
A345,34567,4567,A345,34567,4567 （両方）
, , ,A456,45678,5678 （シート２のみ）
のようにしたいと思います。皆様のお知恵をお借りしたいと思います。
よろしくお願いいたします。

回答No.4

pkh4989 · ベストアンサー

申し訳ありません。
間違いがありましたので、訂正いたします。

If Sh1.Cells(wRow1, 1) = Sh2.Cells(wRow2, 1) Then
'シート1,シート2両方コピー
wCol1 = Sh1.Cells(wRow1, 1).End(xlToRight).Column
Sh1.Range(Sh1.Cells(wRow1, 1), Sh1.Cells(wRow1, wCol1)).Copy _
Destination:=Sh3.Cells(wRow3, 1)
wCol2 = Sh2.Cells(wRow2, 1).End(xlToRight).Column
Sh2.Range(Sh2.Cells(wRow2, 2), Sh2.Cells(wRow2, wCol2)).Copy _
Destination:=Sh3.Cells(wRow3, wCol1 + 1)　'←訂正してください。
'
wRow1 = wRow1 + 1
wRow2 = wRow2 + 1

お礼

お礼が遅くなりまして申し訳ございません。
望んでいた通りの結果になりました。ありがとうございました。

回答No.3

pkh4989

大変失礼致しました。
訂正したマクロです。再度試してみて下さい。

Sub シート結合()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim Sh3 As Worksheet
Dim wMaxRow1 As Long
Dim wMaxRow2 As Long
Dim wRng1 As Range
Dim wRng2 As Range
Dim wRow1 As Long
Dim wRow2 As Long
Dim wRow3 As Long
Dim wCol1 As Integer
Dim wCol2 As Integer
Dim exit_Flg As Boolean
'
Application.ScreenUpdating = False
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
Set Sh3 = Worksheets("Sheet3")
'
'シート1(A列を昇順ソート)
Sh1.Activate
wMaxRow1 = Sh1.Range("A" & Rows.Count).End(xlUp).Row
wCol1 = Sh1.UsedRange.Columns.Count
Set wRng1 = Sh1.Range(Sh1.Cells(1, 1), Sh1.Cells(wMaxRow1, wCol1))
wRng1.Sort Key1:=Range("A1"), Order1:=xlAscending
'
'シート2(A列を昇順ソート)
Sh2.Activate
wMaxRow2 = Sh2.Range("A" & Rows.Count).End(xlUp).Row
wCol2 = Sh2.UsedRange.Columns.Count
Set wRng2 = Sh2.Range(Sh2.Cells(1, 1), Sh2.Cells(wMaxRow2, wCol2))
wRng2.Sort Key1:=Range("A1"), Order1:=xlAscending
'
wRow1 = 1: wRow2 = 1: wRow3 = 1
While exit_Flg = False
If Sh1.Cells(wRow1, 1) = Sh2.Cells(wRow2, 1) Then
'シート1,シート2両方コピー
wCol1 = Sh1.Cells(wRow1, 1).End(xlToRight).Column
Sh1.Range(Sh1.Cells(wRow1, 1), Sh1.Cells(wRow1, wCol1)).Copy _
Destination:=Sh3.Cells(wRow3, 1)
wCol2 = Sh2.Cells(wRow2, 1).End(xlToRight).Column
Sh2.Range(Sh2.Cells(wRow2, 2), Sh2.Cells(wRow2, wCol2)).Copy _
Destination:=Sh3.Cells(wRow3, wCol2 + 1)
'
wRow1 = wRow1 + 1
wRow2 = wRow2 + 1
ElseIf Sh1.Cells(wRow1, 1) < Sh2.Cells(wRow2, 1) Then
If Not IsEmpty(Sh1.Cells(wRow1, 1)) Then
'シート1のみコピー
wCol1 = Sh1.Cells(wRow1, 1).End(xlToRight).Column
Sh1.Range(Sh1.Cells(wRow1, 1), Sh1.Cells(wRow1, wCol1)).Copy _
Destination:=Sh3.Cells(wRow3, 1)
'
wRow1 = wRow1 + 1
Else
'シート2のみコピー
wCol2 = Sh2.Cells(wRow2, 1).End(xlToRight).Column
Sh2.Range(Sh2.Cells(wRow2, 1), Sh2.Cells(wRow2, wCol2)).Copy _
Destination:=Sh3.Cells(wRow3, 1)
'
wRow2 = wRow2 + 1
End If
Else
If Not IsEmpty(Sh2.Cells(wRow2, 1)) Then
'シート2のみコピー
wCol2 = Sh2.Cells(wRow2, 1).End(xlToRight).Column
Sh2.Range(Sh2.Cells(wRow2, 1), Sh2.Cells(wRow2, wCol2)).Copy _
Destination:=Sh3.Cells(wRow3, 1)
'
wRow2 = wRow2 + 1
Else
'シート1のみコピー
wCol1 = Sh1.Cells(wRow1, 1).End(xlToRight).Column
Sh1.Range(Sh1.Cells(wRow1, 1), Sh1.Cells(wRow1, wCol1)).Copy _
Destination:=Sh3.Cells(wRow3, 1)
'
wRow1 = wRow1 + 1
End If
End If
wRow3 = wRow3 + 1
If wRow1 > wMaxRow1 And wRow2 > wMaxRow2 Then
exit_Flg = True
End If
Wend
Application.ScreenUpdating = True
End Sub

回答No.2

pkh4989

No1 です。

シート1、シート2共に、データがある行(有効行数)まで、実行するようになっています。
たぶん、シート１の有効行(３行)以降にスペースが入力されている可能性があるので、３行以降の行を一度削除してから行ってみてください。

補足

何度もありがとうございます。
シート１の４行目以降を削除して実行しましたが、同じでした。
デバッグモードで実行し各行を追いかけたところ
ElseIf Sh1.Cells(wRow1, 1) < Sh2.Cells(wRow2, 1) Then
の行で左辺がＮｕｌｌ（？）の様でこれ以降の処理を実行してしまいます。（例のブックで実行かけました。）
よろしくお願いいたします。

回答No.1

pkh4989

こんにちは。

以下のマクロを試してみてください。

Sub シート結合()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim Sh3 As Worksheet
Dim wMaxRow1 As Long
Dim wMaxRow2 As Long
Dim wRng1 As Range
Dim wRng2 As Range
Dim wRow1 As Long
Dim wRow2 As Long
Dim wRow3 As Long
Dim wCol1 As Integer
Dim wCol2 As Integer
Dim exit_Flg As Boolean
'
Application.ScreenUpdating = False
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
Set Sh3 = Worksheets("Sheet3")
'
'シート1(A列を昇順ソート)
Sh1.Activate
wMaxRow1 = Sh1.Range("A" & Rows.Count).End(xlUp).Row
wCol1 = Sh1.UsedRange.Columns.Count
Set wRng1 = Sh1.Range(Sh1.Cells(1, 1), Sh1.Cells(wMaxRow1, wCol1))
wRng1.Sort Key1:=Range("A1"), Order1:=xlAscending
'
'シート2(A列を昇順ソート)
Sh2.Activate
wMaxRow2 = Sh2.Range("A" & Rows.Count).End(xlUp).Row
wCol2 = Sh2.UsedRange.Columns.Count
Set wRng2 = Sh2.Range(Sh2.Cells(1, 1), Sh2.Cells(wMaxRow2, wCol2))
wRng2.Sort Key1:=Range("A1"), Order1:=xlAscending
'
wRow1 = 1: wRow2 = 1: wRow3 = 1
While exit_Flg = False
If Sh1.Cells(wRow1, 1) = Sh2.Cells(wRow2, 1) Then
'シート1,シート2両方コピー
wCol1 = Sh1.Cells(wRow1, 1).End(xlToRight).Column
Sh1.Range(Sh1.Cells(wRow1, 1), Sh1.Cells(wRow1, wCol1)).Copy _
Destination:=Sh3.Cells(wRow3, 1)
wCol2 = Sh2.Cells(wRow2, 1).End(xlToRight).Column
Sh2.Range(Sh2.Cells(wRow2, 2), Sh2.Cells(wRow2, wCol2)).Copy _
Destination:=Sh3.Cells(wRow3, wCol2 + 1)
'
wRow1 = wRow1 + 1
wRow2 = wRow2 + 1
ElseIf Sh1.Cells(wRow1, 1) < Sh2.Cells(wRow2, 1) Then
'シート1のみコピー
wCol1 = Sh1.Cells(wRow1, 1).End(xlToRight).Column
Sh1.Range(Sh1.Cells(wRow1, 1), Sh1.Cells(wRow1, wCol1)).Copy _
Destination:=Sh3.Cells(wRow3, 1)
'
wRow1 = wRow1 + 1
Else
'シート2のみコピー
wCol2 = Sh2.Cells(wRow2, 1).End(xlToRight).Column
Sh2.Range(Sh2.Cells(wRow2, 1), Sh2.Cells(wRow2, wCol2)).Copy _
Destination:=Sh3.Cells(wRow3, 1)
'
wRow2 = wRow2 + 1
End If
wRow3 = wRow3 + 1
If wRow1 > wMaxRow1 And wRow2 > wMaxRow2 Then
exit_Flg = True
End If
Wend
Application.ScreenUpdating = True
End Sub

'マクロ貼付
(1) Alt+F11 (ツール → マクロ → Visual Basic Editor) →「挿入」→「標準モジュール」で表示される画面に貼り付け
(2) 実行は、(F5を押す)又は、シート画面に戻って Alt＋F8を押してマクロ一覧からマクロ名を選択して実行

補足

早速の回答ありがとうございます。
上記マクロを実行しましたが、シート１のデータがなくなるまで
（例では３行目まで）でいいのですが、４行目以降も実行してしまい時間がかかってしまいました。（途中でブレークし止めました）
有効行数まで行うことは不可能でしょうか？
よろしくお願いいたします。