位置の違う列のデータを項目ごとにまとめる

複数のシートにバラバラに配置されている列データを項目別にまとめたいです。

Sheet1とSheet2の同じ項目を結合してSheet3のようにしたい。
列項目の位置が同じであれば、結合できるフリーソフトを見つけたのですが、
列の位置までは考慮されず使えません。

実際のデータは、それぞれのシートで1000件くらいあります。
コピペだと作業ミスが発生するため、自動的にできる方法を探しています。
アドバイスをお願いいたします。

Windows7・Excel2010を使用しています。

No.1 回答者： tom04 回答日時： 2014/12/09 13:34

こんにちは！

VBAになりますが、一例です。

Sheet1・Sheet2とも1行目が項目行になっていて、A列からデータはあるとします。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim j As Long, lastRow As Long, c As Range
Dim wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
With Worksheets("Sheet3")
.Cells.Clear
wS1.Range("A1").CurrentRegion.Copy .Range("A1")
For j = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
Set c = wS2.Rows(1).Find(what:=.Cells(1, j), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
lastRow = wS2.Cells(Rows.Count, c.Column).End(xlUp).Row
If lastRow > 1 Then
Range(wS2.Cells(2, c.Column), wS2.Cells(lastRow, c.Column)).Copy .Cells(Rows.Count, j).End(xlUp).Offset(1)
End If
End If
Next j
'▼
For j = 1 To wS2.Cells(1, Columns.Count).End(xlToLeft).Column
Set c = .Rows(1).Find(what:=wS2.Cells(1, j), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
lastRow = wS2.Cells(Rows.Count, j).End(xlUp).Row
Range(wS2.Cells(1, j), wS2.Cells(lastRow, j)).Copy .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
End If
Next j
'▲
.Activate
End With
End Sub 'この行まで

※　どちらかのSheetに変更があった場合はその都度マクロを実行する必要があります。

※　とりあえずSheet2の項目でSheet1にない場合は、その右隣りにそのまま表示するようにしていますが、
Sheet2の項目は必ずSheet1にある！というのであれば
コード内の「▼」から「▲」までの行を消去してください。m(_ _)m

この回答への補足

ご回答いただき、ありがとうございます。

希望の作業ができました！！
ありがとうございます。

追加の質問で申し訳ないのですが、教えてください。
結合するシートが増えた場合は、どの部分を修正したら良いのでしょうか？

Dim wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
この部分を追加して

Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Set wS3 = Worksheets("aaa") ←追加したシート
と修正して見ましたが、結合されませんでした。

よろしくお願いいたします。

補足日時：2014/12/09 14:39

No.2 回答者： tom04 回答日時： 2014/12/09 17:09

No.1です。

＞シートが増えた場合は、どの部分を修正したら良いのでしょうか？

この際ですので、Sheet名やSheet数を気にすることなく「まとめたいSheet」以外のSheetを
「まとめたいSheet」にすべてまとめてみてはどうでしょうか？

仮にまとめたいSheetのSheet名を　まとめ　とした場合のコードです。
前回同様標準モジュールです。

Sub Sample2()
Dim j As Long, k As Long, lastRow As Long, cnt As Long
Dim c As Range, wS As Worksheet
With Worksheets("まとめ") '←「まとめ」は実際のSheet名に！
'▼「まとめ」Sheetデータを消去
.Cells.Clear
'▼Sheet見出しの一番左側Sheetから順にループ
For k = 1 To Worksheets.Count
'▼Sheet名が「まとめ」でない場合、そのSheetを変数「wS」に格納
If Worksheets(k).Name <> .Name Then
Set wS = Worksheets(k)
'▼そのSheetのA列～最終列までループし、「まとめ」Sheetの1行目に同じ項目名があるかどうか検索
For j = 1 To wS.Cells(1, Columns.Count).End(xlToLeft).Column
Set c = .Rows(1).Find(what:=wS.Cells(1, j), LookIn:=xlValues, lookat:=xlWhole)
'▼同じ項目名がない場合、「まとめ」Sheetの1行目左詰めにそのSheetの「j」列データをコピー＆ペースト
If c Is Nothing Then
lastRow = wS.Cells(Rows.Count, j).End(xlUp).Row
cnt = cnt + 1
Range(wS.Cells(1, j), wS.Cells(lastRow, j)).Copy .Cells(1, cnt)
'▼同じ項目名がある場合、そのSheetの「j」列2行目～最終行を「まとめ」Sheetの同じ項目列の最終行の1行下にコピー＆ペースト
Else
lastRow = wS.Cells(Rows.Count, j).End(xlUp).Row
If lastRow > 1 Then
Range(wS.Cells(2, j), wS.Cells(lastRow, j)).Copy .Cells(Rows.Count, c.Column).End(xlUp).Offset(1)
End If
End If
Next j
End If
Next k
.Activate
End With
End Sub

※　「まとめ」SheetのSheet名は好みのSheet名にしてください。
※　「まとめ」SheetはSheet見出しの何番目にあっても対応できるようにしてみました。m(_ _)m

この回答への補足

tom04さま

ご回答いただき、ありがとございます。
お返事が遅くなり、失礼いたしました。
お陰様で、希望のデータが作成できました。
VBAを使用すると作業が劇的に早くでき驚きました。

コードの内容で一つ質問させてください。

'▼同じ項目名がない場合、「まとめ」Sheetの1行目左詰めにそのSheetの「j」列データをコピー＆ペースト

この部分で「j」列を指定されていますが、何か理由があるのでしょうか？
コードの意味がボンヤリとしか理解できないので、
「j」が登場する意味が解らず質問させていただきました。

よろしくお願いいたします。

補足日時：2014/12/10 10:20

No.3 ベストアンサー 回答者： tom04 回答日時： 2014/12/10 19:21

続けてお邪魔します。

No.2の補足の件に関して
＞'▼同じ項目名がない場合、「まとめ」Sheetの1行目左詰めにそのSheetの「j」列データをコピー＆ペースト
＞この部分で「j」列を指定されていますが、何か理由があるのでしょうか？
＞コードの意味がボンヤリとしか理解できないので、
＞「j」が登場する意味が解らず質問させていただきました。

細かく説明するより全体の流れを説明した方が判りやすいと思います。

（1）
変数「k」はSheet見出しの左から順にSheet数だけループさせます。
左から「k」番目Sheet「Worksheets(k)」（一番左側Sheetは「Worksheets(1)」となります。
それを変数「wS」に格納しています。
（コード内でいちいち「Worksheets(k)」と入力する手間を省くため）

（2）
その「wS」の名前が「まとめ」でない場合は、A列から1行目項目が入っている最終列までループさせます。
その変数として「j」を使用しています。
j=1　の時は「A」列・j=2　の時は「B」列・・・と1行目項目が入っている最終列まで繰り返します。
＞For j = 1 To wS.Cells(1, Columns.Count).End(xlToLeft).Column
の部分がそれに当たります。

（3）
「まとめ」Sheetの1行目を「wS」の1行目j列を検索値として検索します。
「まとめ」Sheetの1行目に「wS」1行目j列のデータがない場合は
＞cnt = cnt + 1
として、列数を増やして、その列の1行目に「wS」のj列データすべてをコピー＆ペーストします。
※　変数「cnt」の初期値は「0」ですので、
＞cnt = cnt + 1
で「1」となり、「まとめ」Sheetの
＞Range(wS.Cells(1, j), wS.Cells(lastRow, j)).Copy .Cells(1, cnt)
で「A1」セルにコピー＆ペースト　というコトになります。
「まとめ」Sheet1行目項目に「wS」の1行目j列項目がなければ「cnt」はそのたびに「1」ずつプラスされますので
A　→　B　→　C列・・・と順にコピー＆ペーストする列が右にずれていきます。
尚、コードの最初の方にある
＞.Cells.Clear
は　
＞With Worksheets("まとめ")
とつながっていますので、
＞Worksheets("まとめ").Cells.Clea　として、一旦「まとめ」Sheetのデータをすべて消去していますのでまっさらなSheetとなり、
最初のSheetの場合はすべてのデータがそのまま「まとめ」Sheetに表示されます。

（4）
以上の操作を「まとめ」Sheet以外のすべてのSheetで繰り返すようにしています。
「まとめ」Sheetの1行目にすでに「wS」の1行目項目が存在する場合は
＞Range(wS.Cells(2, j), wS.Cells(lastRow, j)).Copy .Cells(Rows.Count, c.Column).End(xlUp).Offset(1)
の中の
＞C.Column
が同じ項目名が存在する「列」番号となりますので、
「まとめ」Sheetの同じ項目列の最終行の次の行に「wS」j列データ2行目～最終行をコピー＆ペースト

といった操作の繰り返し。

以上が前回のコードの流れです。
長々と書きましたが
この程度でどうでしょうか？m(_ _)m

この回答へのお礼

tom04さま

詳細な説明をいただき、ありがとうございます。
それぞれのコードの組み合わせは未だ理解できない部分が多いですが、
流れは理解できました。
ポイントは「変数」ですね…

お教えいただいた内容を理解できるように、勉強したいと思います。
また、何かございましたら、よろしくお願いいたします。

この度は、本当にありがとうございました。

お礼日時：2014/12/11 09:51