エクセルの抽出？のマクロ作成について

質問

こんばんは、じつはエクセルでどうしても整理したい事項がありましてどうやらマクロでやらないとすごい時間かかりそうなもので、是非ともお教えいただきたいのですが（VBAはほとんど初心者です＾＾；；）

例えば
ガンダムのおもちゃが置いてある店のリストのシートと
ルパンのおもちゃが置いてある店のリストのシートと
ドラクエのおもちゃが置いてある店のリストのシートの３つのシートを手に入れている場合に

ガンダムは a,b,c,dの4店にあり
ルパンは b,c,d,e の4店にあり
ドラクエは　d,eの2店にあるようなばあいに

a店　ガンダム
b　ガンダム　ルパン
c　ガンダム　ルパン
d　ガンダム　ルパン　ドラクエ
e　ルパン　ドラクエ

というようにわかりやすくどのおもちゃはどこに何種類おいているかの表をつくりたいのですが、どのようにマクロを作成したらよいのでしょうか？？

是非お教えいただけると幸いです。よろしくお願いします。

回答No.4

imogasi · ベストアンサー

本件の質問例は「例え話し」のようですが、
質問がエクセルシートに即して具体的でないので、VBAコードを挙げても、ご質問者が自分の実際のケースに合わせて修正可能する力があるかどうか心配です。
（データ）各シートのA1以下に、同一フォーマットで
Sheet1に
A列　　　B　C　D　E
ガンダム　a　b　c　d
Sheet2に
A列　　　B　C　D　E
ルパン b c d e
Sheet3に
A列　　　B　C　D　E
ドラクエ d e
（ロジック）
（A）各シートを１シートに集める。手動で貼りつけが簡単ですが、シート数が多いと仮定してVBAでやる。
（B)これをガンダム－ａ，ガンダム－ｂ・・・のように
玩具－販売店の２項目の組み合わせ行に分解する。
A列玩具、B列販売店になる。
（C)それを販売店をキーにして、並び替える
　　これで１つの販売店の玩具の行は固まった行になる。
（D)この販売店では多数行を販売店をA列、玩具をB、C、D・・列にならべ、１行内に並べる
（Ｓｈｅｅｔ１）
玩具 販売店
ガンダム a b c d
ゴジラ ｃ ａ
（Ｓｈｅｅｔ２）
玩具 販売店
ルパン ｂ ｃ ｄ ｅ
キメラ ｆ ａ
リカ ｄ ｂ ａ
（Ｓｈｅｅｔ３）
玩具 販売店
ドラクエ ｄ ｅ ｆ
パンチ ｇ ｃ
ポケモン ｆ ａ
モンスタ ｄ ｂ
（Ｓｈｅｅｔ４）Ｓｈｅｅｔ１－Ｓｈｅｅｔ３を１シートに集めた
ガンダム a b c d
ゴジラ ｃ ａ
ルパン ｂ ｃ ｄ ｅ
キメラ ｆ ａ
リカ ｄ ｂ ａ
ドラクエ ｄ ｅ ｆ
パンチ ｇ ｃ
ポケモン ｆ ａ
モンスタ ｄ ｂ
（Ｓｈｅｅｔ５）玩具と店に分解
ガンダム a
ガンダム b
ガンダム c
ガンダム d
ゴジラ ｃ
ゴジラ ａ
ルパン ｂ
ルパン ｃ
ルパン ｄ
ルパン ｅ
キメラ ｆ
キメラ ａ
リカ ｄ
リカ ｂ
リカ ａ
ドラクエ ｄ
ドラクエ ｅ
ドラクエ ｆ
パンチ ｇ
パンチ ｃ
ポケモン ｆ
ポケモン ａ
モンスタ ｄ
モンスタ ｂ
（Ｓｈｅｅｔ５（２））手動でＢ列をキーにしてソート
ゴジラ ａ
キメラ ａ
リカ ａ
ポケモン ａ
ガンダム ｂ
ルパン ｂ
リカ ｂ
モンスタ ｂ
ガンダム ｃ
ゴジラ ｃ
ルパン ｃ
パンチ ｃ
ガンダム ｄ
ルパン ｄ
リカ ｄ
ドラクエ ｄ
モンスタ ｄ
ルパン ｅ
ドラクエ ｅ
キメラ ｆ
ドラクエ ｆ
ポケモン ｆ
パンチ ｇ
（Ｓｈｅｅｔ６）望みの表に再編成
ａ ガンダム ゴジラ キメラ リカ ポケモン
ｂ ガンダム ルパン リカ モンスタ
ｃ ガンダム ゴジラ ルパン パンチ
ｄ ガンダム ルパン リカ ドラクエ モンスタ
ｅ ルパン ドラクエ
ｆ キメラ ドラクエ ポケモン
ｇ パンチ
（ＶＢＡコード）
１シートに統合
Sub test01()
Dim sh As Worksheet
j = 1
For Each sh In ActiveWorkbook.Worksheets
If sh.Name = "Sheet4" Then GoTo p01
d = sh.Range("A65536").End(xlUp).Row
For i = 2 To d
sh.Cells(i, "A").EntireRow.Copy
Worksheets("Sheet4").Cells(j, "A").PasteSpecial
j = j + 1
Next i
p01:
Next
End Sub
玩具と店の行に分解
Sub test02()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("sheet4")
Set sh2 = Worksheets("sheet5")
k = 1
d = sh1.Range("A65536").End(xlUp).Row
For i = 1 To d
For j = 2 To 250
If sh1.Cells(i, j) = "" Then Exit For
sh2.Cells(k, "A") = sh1.Cells(i, "A")
sh2.Cells(k, "B") = sh1.Cells(i, j)
k = k + 1
Next j
Next i
End Sub
店別に並べ替え後
玩具－店の行から店－玩具（複数列）に組替え。
Sub test03()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("Sheet5 (2)")
Set sh2 = Worksheets("Sheet6")
k = 1: j = 2
d = sh1.Range("A65536").End(xlUp).Row
m = sh1.Cells(1, "B")
For i = 1 To d
If sh1.Cells(i, "B") = m Then
Else
k = k + 1
j = 2
m = sh1.Cells(i, "B")
End If
sh2.Cells(k, "A") = sh1.Cells(i, "B")
sh2.Cells(k, j) = sh1.Cells(i, "A")
j = j + 1
Next i
End Sub

お礼

すごく色々考えてもらえたようで恐縮ですｍ（　）ｍ
しかしこちらの説明不足でお教えしてもらった形式とはちょっと違うのですが、これからお教えしてもらった式も参考にしながら再度自分でも考えていきたいとおもいます

ご回答ありがとうございます＾＾

回答No.3

DoragonFang

とりあえず、作ってみました。
前提条件として、シートは「ガンダム」「ルパン」「ドラクエ」となっていて、最後にまとめるための「shops」というシートがあるとします。
「ガンダム」「ルパン」「ドラクエ」はＡ１セルから、下に向かって、
a
b
c
d
と順に店の名前が入っているものとします。途中に空欄は許されません。

で、以下のマクロを使用します。

Sub shop()
Dim S(20, 20) As Integer
Dim WN(20) As String
Dim A As String
Dim SMax As Integer
Dim WMax As Integer
Dim i As Integer
Dim j As Integer

WMax = Worksheets.Count - 1
For i = 1 To WMax
Worksheets(i).Activate
WN(i) = ActiveSheet.Name
For j = 1 To 20
A = Worksheets(i).Cells(j, 1).Value
If A = "" Then Exit For
S(i, Asc(A) - 96) = 1
If SMax < (Asc(A) - 96) Then SMax = Asc(A) - 96
Next
Next
Worksheets("shops").Activate
Range("A2").Activate
For i = 1 To SMax
Cells(i + 1, 1).Value = Chr(96 + i)
For j = 1 To WMax
If S(j, i) = 1 Then
Cells(i + 1, j + 1).Value = WN(j)
End If
Next j
Next i

End Sub

とりあえず、
a ガンダム
b ガンダム　ルパン
c ガンダム　ルパン
d ガンダム　ルパン　ドラクエ
e 　　　　　ルパン　ドラクエ

となるはず。。

お礼

すごい長い式をかんがえてくださってありがたいですｍ（　）ｍ
だいたい仮定のとうりのシートなのですが実はもうちょっといろいろしたいところがありまして・・・。
doragonさんの式を参考にもうちょっと勉強してみたらできそうな感じがします！

ご回答ありがとうございました＾＾

回答No.2

BLUEPIXY

一応、作ってみました。
シート名がガンダム、ルパン、ドラクエとなっていて
各シートのＡ列
店名
a
b
c
のような感じで書かれていることを想定しています。
統合シートに結果を書き込みます

店名のリストは、必要によりソートして下さい。

Public Sub まとめる()
Dim list, hasList()
Dim x, i As Integer, j, k As Integer
Dim base As Range
Dim sheetArray
Set list = CreateObject("Scripting.Dictionary")
list.CompareMode = vbTextCompare '大文字小文字、全角半角、カナひらを区別しない
sheetArray = Array(Sheets("ガンダム"), Sheets("ルパン"), Sheets("ドラクエ"))
ReDim hasList(UBound(sheetArray))
'集計
For i = 0 To UBound(sheetArray)
Set hasList(i) = CreateObject("Scripting.Dictionary")
Set base = sheetArray(i).Range("A2") '項目名があるので、その次から（Ａ列に）店名が入っている
j = 0
Do While base.Offset(j).Value <> ""
If Not list.Exists(base.Offset(j).Value) Then list.Add base.Offset(j).Value, base.Offset(j).Value '店リスト作成
hasList(i).Add base.Offset(j).Value, True '商品毎の店リスト作成、ダブりは無いことが前提
j = j + 1
Loop
Next
'集計結果の表示
Sheets("統合").Cells.ClearContents
Set base = Sheets("統合").Range("A1")
j = 0
base.Offset(j).Value = "店名": j = j + 1
For Each x In list.keys
base.Offset(j, 0).Value = list.Item(x) '店名
k = 0
For i = 0 To UBound(sheetArray)
If hasList(i).Exists(x) Then 'その商品の店名リストにある？
base.Offset(j, 1 + k).Value = sheetArray(i).Name
k = k + 1
End If
Next
j = j + 1
Next
End Sub

回答No.1

helonpa

どの程度の量があるリストなのか、シートは更新されるのかなどよく分からないのであれですが、

全部のシートを１つにまとめ、全行の先頭に店名を加え、店名で並べ替えたら如何ですか。

お礼

じつはその方法でもやってみたのですがいまひとつスッキリ表示ができなかったもので・・・

ご回答ありがとうございました。