重複するデータを複数条件で抽出するマクロについて

質問

すみません、困っています。。　どなたか、教えて頂けますか？

複数のテーマ別に応募してきた顧客の希望について、

第３希望までをテーマ別に、sheet1に整理していくマクロを検討しています。

希望順に、テーマＪ１からオートフィルターで名前を抽出して、

それを、Sheet1のテーマ別にコピーしていく方法を繰り返すのがよいのか、悩んでいます。

完成形としては、sheet1に、Ａ列にテーマ、それに対応して、Ｂ列から顧客の名前を希望順に、

抽出し右列方向に張り付けていきます。

実際には、テーマは100を超え、顧客数も200を超え、第５希望までの大量になります。

お知恵をお貸しくださいませ。

sheet1 　　　　sheet2 　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　
テーマ　　　　　　　　　顧客　　第１　　第２　　第３ （希望テーマ）
Ｊ１　　　　　　　　　　　Ａさん 　Ｊ１　　　Ｊ４　 　Ｊ５　　　　　　　　　　　　　　
Ｊ２　　　　　　　　　　　Ｂさん 　Ｊ１ 　 　Ｊ３ 　　J4
Ｊ３　　　　　　　　　　　Ｃさん 　Ｊ３ 　　　Ｊ２ 　J１
Ｊ４　　　　　　　　　　　Ｄさん 　Ｊ２ 　　 Ｊ4 　　J５
Ｊ５　　　　　　　　　　　Ｅさん 　Ｊ３ 　　　Ｊ１ 　 J４

宜しくお願い致します。

回答No.5

tom04 · ベストアンサー

No.3です！
無理矢理やってみました。
Sheet3を作業用のSheetとして使用していますので、Sheet3は全く使っていない！という前提です。

Alt＋F11キー　→　画面左の「This Workbook」をダブルクリック　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i, j, k, M As Long
Dim ws1, ws2, ws3 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
ws1.Cells(1, 1) = "テーマ"
Range(ws2.Cells(1, 2), ws2.Cells(1, 6)).Copy Destination:=ws1.Cells(1, 2)
i = ws1.UsedRange.Rows.Count
If i > 1 Then
Range(ws1.Cells(2, 1), ws1.Cells(i, 6)).ClearContents
End If
For i = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To 6
If WorksheetFunction.CountIf(ws2.Columns(7), ws2.Cells(i, j)) = 0 Then
k = k + 1
ws2.Cells(k, 7) = ws2.Cells(i, j)
End If
Next j
Next i
ws2.Columns(7).Sort key1:=ws2.Cells(1, 7), order1:=xlAscending
For k = 1 To ws2.Cells(Rows.Count, 7).End(xlUp).Row
ws3.Cells(1, 1) = "作業用Sheet"
For j = 2 To 6
For i = 2 To ws2.Cells(Rows.Count, j).End(xlUp).Row
If ws2.Cells(i, j) = ws2.Cells(k, 7) Then
ws3.Cells(Rows.Count, j).End(xlUp).Offset(1) = ws2.Cells(i, 1)
End If
Next i
Next j
M = ws3.UsedRange.Rows.Count
i = ws1.UsedRange.Rows.Count
ws1.Cells(i + 1, 1) = ws2.Cells(k, 7)
Range(ws3.Cells(2, 2), ws3.Cells(M, 6)).Copy Destination:=ws1.Cells(i + 1, 2)
ws3.Cells.ClearContents
M = 0
Next k
ws2.Columns(7).ClearContents
Application.ScreenUpdating = True
End Sub 'この行まで

※　データは第5希望（F列）までとしています。

こちらで勝手に判断していますので、
お望みの表示でなかったらごめんなさいね。m（_ _）m

お礼

重ねて心より、感謝申し上げます。
このマクロがなかったら、、と思うと、また、これだけのマクロを組むとなると、、
私には、とうてい無理なので、本当に有難いです。
テーマより顧客数の方が２倍と多いので、この表示の方が、
希望順位別に顧客をチェックしやすいので、助かります。
ありがとうございました！！

回答No.4

keithin

＞誰が第一希望なのか、第二希望なのか、、分かるように、区分したい

それは元のご相談とは別の、新たなご相談事項です。
ダラダラとついでについでにと質問を後出しせず、そういう新しい課題は元のこのご相談を解決で一回閉じた後、改めてのご相談として投稿しなおしてください。

その際に「区分してどのように示したいのか」区分した結果の「具体的な姿」をアナタがご自分のアタマで考えて、「こうしたい」とヤリタイ事をキチンと添えて、情報提供するようにしてください。
言葉を換えると、「ついでにきいちゃえばついでに教えてくれるだおう」と軽～い気持ちで書いているから、一体ご自分が何をしたいのかご相談で説明するのを忘れていますよと指摘しています。

sub macro2()
　dim r as long
　dim c as range
　dim c0 as string
　dim s as long

　on error resume next　
　for s = 2 to worksheets("Sheet2").range("IV1").end(xltoleft).column
　worksheets("Sheet1").copy after:=worksheets("Sheet1")
　activesheet.name = worksheets("Sheet2").cells(1,s).value

　on error goto 0
　for r = 2 to range("A65536").end(xlup).row
　　set c = worksheets("Sheet2").columns(s).find(what:=cells(r, "A").value, lookin:=xlvalues, lookat:=xlwhole)
　　if not c is nothing then
　　　c0 = c.address
　　　do
　　　　cells(r, "IV").end(xltoleft).offset(0, 1) = worksheets("Sheet2").cells(c.row, "A")
　　　　set c = worksheets("Sheet2").columns(s).findnext(c)
　　　loop until c.address = c0
　　end if
　next r
　next s
end sub

お礼

ありがとうございました。
ＶＢＤの知識が乏しく、ご指摘の説明不足で不躾な点はお詫び申し上げます。
希望別のシート作成を参考にさせて頂きます。大変助かりました。

回答No.3

tom04

こんばんは！
一例です。

画面左下のSheet1のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
※　両Sheetとも1行目はタイトル行で、データは2行目以降にあるとします。

Sub test() 'この行から
Dim i, j, k As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
Application.ScreenUpdating = False
i = Cells(Rows.Count, 1).End(xlUp).Row
If i > 1 Then
Rows(2 & ":" & i).ClearContents
End If
For j = 2 To 4
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Columns(1), ws.Cells(i, j)) = 0 Then
Cells(Rows.Count, 1).End(xlUp).Offset(1) = ws.Cells(i, j)
End If
Next i
Next j
i = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(2, 1), Cells(i, 1)).Sort key1:=Cells(1, 1), order1:=xlAscending
For k = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To 4
For i = 2 To ws.Cells(Rows.Count, j).End(xlUp).Row
If ws.Cells(i, j) = Cells(k, 1) Then
Cells(k, Columns.Count).End(xlToLeft).Offset(, 1) = ws.Cells(i, 1)
End If
Next i
Next j
Next k
Application.ScreenUpdating = True
End Sub 'この行まで

こんな感じではどうでしょうか？m（_ _）m

お礼

ありがとうございました。
容量を得ない初めての投稿で、また、ＶＢＤの知識の乏しい者の投稿として不躾な点は、ご容赦くださいませ。
頂いた構文を勉強して、完成させます。
大変助かりました。心より感謝申し上げます。

補足

早速にありがとうございます！素晴らしいです。　
私の説明が悪くて申し訳ないのですが、、
Sheet1へ、テーマ別に記載された顧客の名前が、
誰が第一希望なのか、第二希望なのか、、分かるように、
区分したいのですが、どのようにすれば宜しいでしょうか？
ご教授頂けますでしょうか？
度々、申し訳ございません。。

回答No.2

bin-chan

例示データ（Sheet2）の場合に、Sheet1にどうあって欲しいのか、詳しく書いてみてください。

ざっとですが、Sheet2を元に新たにSheet3を起こしてみるとか。
（もちろんVBAで）

・Sheet3の列は顧客・Ｊ１・Ｊ２・Ｊ３・Ｊ４・Ｊ５（100あるなら以降ほしいだけ）
・Sheet3の行はSheet2の顧客（Sheet2の行方向に処理を進める）
１）顧客の第一希望に記入しているコースを判断し、Sheet3の該当コースに列に 1 を立てる。
２）顧客の第二希望に記入しているコースを判断し、Sheet3の該当コースに列に 2 を立てる。
３）顧客の第三希望に記入しているコースを判断し、Sheet3の該当コースに列に 3 を立てる。
４）一行下の顧客にうつり、存在するなら１）から繰り返し。

Sheet2の全顧客の希望をSheet3に転記したら、オートフィルタかけるなり加工。

お礼

早々と、ありがとうございました。
説明不足で申し訳ございませんでした。
希望別にシート別にする点を参考にさせて頂きます。
大変助かりました。

回答No.1

keithin

ご質問に書かれている通り、シート１のＡ列Ａ２以下に、テーマの一覧は作成済みとします。
シート２のＡ列に顧客名が列記されているとします。

マクロを使うなら教科書通りのごく簡単な力技で、ぐるぐるしていくだけで十分です。

sub macro1()
　dim r as long
　dim c as range
　dim c0 as string

　for r = 2 to worksheets("Sheet1").range("A655536").end(xlup).row
　　set c = worksheets("Sheet2").cells.find(what:=worksheets("Sheet1").cells(r, "A").value, lookin:=xlvalues, lookat:=xlwhole)
　　if not c is nothing then
　　　c0 = c.address
　　　do
　　　　worksheets("Sheet1").cells(r, "IV").end(xltoleft).offset(0, 1) = worksheets("Sheet2").cells(c.row, "A")
　　　　set c = worksheets("Sheet2").cells.findnext(c)
　　　loop until c.address = c0
　　end if
　next
end sub

お礼

ありがとうございました。
容量を得ない初めての投稿で、また、ＶＢＤの知識の乏しい者の投稿として不躾な点は、ご容赦くださいませ。
頂いた構文を勉強して、完成させます。
大変助かりました。心より感謝申し上げます。

補足

早速にありがとうございます！素晴らしいです。　
私の説明が悪くて申し訳ないのですが、、
Sheet1へ、テーマ別に記載された顧客の名前が、
誰が第一希望なのか、第二希望なのか、、分かるように、
区分したいのですが、どのようにすれば宜しいでしょうか？
ご教授頂けますでしょうか？
度々、申し訳ございません。。