複数のシートに重複する文字列の抽出

質問

教えてgooの利用は初めてです。
どなたかお時間ある方、お知恵を貸していただけると幸いです。
Excel初心者です。

Sheet1(会合名)
AAA会社 | 鈴木 一郎 | Sheet1
BBB会社 | 田中 ニ郎 | Sheet1
CCC会社 | 佐藤 三郎 | Sheet1

Sheet2
BBB会社 | 田中 ニ郎 | Sheet2
DDD会社 | 渡辺 四朗 | Sheet2
EEE会社 | 伊藤 五郎 | Sheet2

Sheet3
BBB会社 | 田中 ニ郎 | Sheet3
CCC会社 | 佐藤 三郎 | Sheet3
FFF会社 | 高橋 六郎 | Sheet3

上記のようにシート毎に数百件ずつ会社名・氏名・住所等が記載された複数のリストがあります
これらの中から名前が重複してる人だけを抽出し
Sheet4
田中 ニ郎 | Sheet1
田中 ニ郎 | Sheet2
田中 ニ郎 | Sheet3
佐藤 三郎 | Sheet1
佐藤 三郎 | Sheet3
このSheet4のように重複している名前とシート名が分かる形で抽出できないでしょうか？
具体的には各会合に参加している出席者で、出席頻度の高い人・出席した会合名を一覧で表示したいと考えています。

回答No.5

tom04 · ベストアンサー

No.2です。

＞Sheet数が4以上になった場合にも・・・
というコトですので、前回のコードに少し手を加えてみました。
今回も前提条件があります。
（1）Sheet数は3つ以上で最低限2Sheetのデータがあり、最終Sheetに重複データを表示する。
（仮に、5Sheetを前回のようにしたい場合はSheet見出し上に6Sheet存在していて、
6番目のSheetに重複データを表示する。）

（2）各Sheetとも1行目が項目行でデータは2行目以降にある！

以上の条件で、Sheet数がいくつでも対応できるようにしてみました。
（コード内に若干の説明を加えています。）

Sub Sample2()
Dim i As Long, k As Long, endRow As Long, endSh As Long, c As Range, wS1 As Worksheet, wS2 As Worksheet
endSh = Worksheets.Count
Application.ScreenUpdating = False
Set wS1 = Worksheets(endSh) '←データ表示用Sheet（最終Sheet）を変数「wS1」に！
With wS1
.Cells.Clear
.Range("A1") = "氏名"
.Range("B1") = "Sheet名"
End With
Worksheets.Add after:=wS1 '最終Sheetの後に作業用のSheetを追加
Set wS2 = Worksheets(endSh + 1) '追加したSheetを変数「wS2」に！
For k = 1 To endSh - 1 'Sheet見出しの一番左から表示用Sheetの一つ前まで
With Worksheets(k) 'Sheet「k」の・・・
endRow = .Cells(Rows.Count, "A").End(xlUp).Row '最終行を取得
If endRow > 1 Then '最終行が2以上の場合（データがある場合）
'Sheet「k」のB2～B列最終行を「作業用」SheetのA列最終行の1行下へコピー＆ペースト
Range(.Cells(2, "B"), .Cells(endRow, "B")).Copy wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
End With
Next k
'作業用SheetのB列に出現回数を表示
endRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row
With Range(wS2.Cells(2, "B"), wS2.Cells(endRow, "B"))
.Formula = "=COUNTIF(A:A,A2)"
.Value = .Value
End With
'「作業用」Sheetの1回のみ出現（重複していない）データを削除
With wS2.Range("A2").CurrentRegion
.AutoFilter field:=2, Criteria1:=1
.SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
End With
wS2.AutoFilterMode = False
'「作業用」Sheetの最終行から上に向かって重複データを削除
For i = wS2.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(wS2.Range("A:A"), wS2.Cells(i, "A")) > 1 Then
wS2.Rows(i).Delete
End If
Next i
For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row '「作業用」Sheetの2行目～最終行まで
For k = 1 To endSh - 1 'Sheet見出しの一番左のSheet～「表示用Sheet」の一つ前のSheetまで
'Sheet「k」のA列に「作業用」SheetのA列データがあるかどうかを見つける
Set c = Worksheets(k).Range("B:B").Find(what:=wS2.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then 'もしデータがある場合は・・・
With wS1.Cells(Rows.Count, "A").End(xlUp).Offset(1) '「表示用」SheetのA列最終行の1行下へ
.Value = wS2.Cells(i, "A") '「作業用」SheetのA列「i」行目データを！
.Offset(, 1) = Worksheets(k).Name 'その右隣りのセルにSheet「k」のSheet名を！
End With
End If
Next k
Next i
'「作業用」Sheetの削除
Application.DisplayAlerts = False
wS2.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
wS1.Activate
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

理想通りの動作を確認できました。
一つ一つのコードの説明まで細かくて本当に助かりました。マクロの改変や勉強の端緒にしていこうと思います。
きめ細かいご対応重ね重ねありがとうございました。

回答No.4

bunjii

>こちらを試してみたところ
>C3に　'); } catch (error) {}
>C4に　=IF(COUNTIFS(Sheet1!A$3:A$22,"="&A3,Sheet1!B$3:B$22,"="&B3),"○","")
>と表示され、自分には手詰まりとなってしまいました。
セルを選択して直接貼り付けすると目的通りの関数式が入力されません。
貼り付けの中の「形式を選択して貼り付け」を選んで形式を「テキスト」に指定してください。
または数式バーに貼り付けてください。
コピー時に改行マークも含んでいると数式バーに貼り付けたとき数式バーに何も見えなくなりますがEnterキーで確定しても問題ないと思います。

共通名簿はSheet4として作成しましたがシート名は臨機応変に変えて差し支えありません。
シート数が増えれば会合名の列が増えるだけで関数式はシート名を変更するだけで流用可能です。
尚、共通名簿は各シートから会社名と氏名をコピーして「データ」タブの「重複の削除」で重複データを削除しました。

お礼

動作確認できました！
シンプルで分かりやすい数式に加え、基本的な操作のご案内も頂き本当に助かりました。
他の方に頂いたアドバイスと共に、bunjiiさんに教えていただいた機能も活用させていただきます。
ありがとうございました。

回答No.3

bunjii

>このSheet4のように重複している名前とシート名が分かる形で抽出できないでしょうか？
質問とは様子が異なるものですが名簿の管理用として試作してみました。

○印が会合に参加するメンバーとして一覧できる形です。
会合名毎に会社名と氏名が一致した交点に○印を入れてあります。
Excel 2007以降のバージョンで以下の式とします。

Sheet1（A協議会）
C3=IF(COUNTIFS(Sheet1!A$3:A$22,"="&A3,Sheet1!B$3:B$22,"="&B3),"○","")
Sheet2（B協議会）
D3=IF(COUNTIFS(Sheet2!A$3:A$22,"="&A3,Sheet2!B$3:B$22,"="&B3),"○","")
Sheet3（C協議会）
E3=IF(COUNTIFS(Sheet3!A$3:A$22,"="&A3,Sheet3!B$3:B$22,"="&B3),"○","")

画像を添付しましたので参考にしてください。
意にそぐわないときは無視して頂いて結構です。

お礼

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

>> C3=IF(COUNTIFS(Sheet1!A$3:A$22,"="&A3,Sheet1!B$3:B$22,"="&B3),"○","")

こちらを試してみたところ
C3に　'); } catch (error) {}
C4に　=IF(COUNTIFS(Sheet1!A$3:A$22,"="&A3,Sheet1!B$3:B$22,"="&B3),"○","")
と表示され、自分には手詰まりとなってしまいました。
自分のリストのどこかに問題があるか、関数のどこかを弄らなくてはいけないのかもしれません。
出席回数の表示が出来るのは大変魅力的ですし、いただいたヒントを元に調整してみようと思います。
ありがとうございました。

回答No.2

tom04

こんばんは！
氏名だけの重複で判断すればよいのですね？

VBAになってしまいますが、一例です。
前提条件として・・・
（1）開いているBookには4つのSheetが表示されている。
（2）Sheet見出しの一番左から3番目Sheetのデータを4番目のSheetに表示する。
（3）4番目のSheetに表示するのは、各SheetのB列氏名とSheet名だけ！
（4）各Sheetとも1行目は項目行で、データは2行目以降にある！

以上の条件で。

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

Sub Sample1() 'この行から
Dim i As Long, k As Long, endRow As Long, c As Range, wS4 As Worksheet, wS5 As Worksheet
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wS4 = Worksheets(4)
Set wS5 = Worksheets(5)
Application.ScreenUpdating = False
wS4.Cells.Clear
With wS4.Range("A1")
.Value = "氏名"
.Offset(, 1) = "Sheet名"
End With
For k = 1 To 3
With Worksheets(k)
endRow = .Cells(Rows.Count, "A").End(xlUp).Row
If endRow > 1 Then
Range(.Cells(2, "B"), .Cells(endRow, "B")).Copy wS5.Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
End With
Next k
endRow = wS5.Cells(Rows.Count, "A").End(xlUp).Row
With Range(wS5.Cells(2, "B"), wS5.Cells(endRow, "B"))
.Formula = "=COUNTIF(A:A,A2)"
.Value = .Value
End With
With wS5.Range("A2").CurrentRegion
.AutoFilter field:=2, Criteria1:=1
.SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
End With
For i = wS5.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(wS5.Range("A:A"), wS5.Cells(i, "A")) > 1 Then
wS5.Rows(i).Delete
End If
Next i
For i = 2 To wS5.Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To 3
Set c = Worksheets(k).Range("B:B").Find(what:=wS5.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
With wS4.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = wS5.Cells(i, "A")
.Offset(, 1) = Worksheets(k).Name
End With
End If
Next k
Next i
Application.DisplayAlerts = False
wS5.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
wS4.Activate
End Sub 'この行まで

※　関数でないので、データ変更があるたびにマクロを実行する必要があります。m(_ _)m

お礼

詳細なご説明ありがとうございます。
希望通りの動作で大変助かりました。

一点だけお伺いしたいのですが、Sheet数が4以上になった場合にも対応できませんでしょうか？
エディタを弄って数字を入れ替えたりはしてみたのですが、浅学のため上手く機能できませんでした。

お時間ある時で結構ですのでご対応いただけたら幸いです。

補足

補足です。
大変重要なことを書き忘れていて申し訳ないのですが、Excelのバージョンは2013です。

回答No.1

keithin

１枚目のシート名を「必ず」Sheet1にします。会合名とかは，実際のシートのＣ列に会合名として記入しておきます
同様に
２枚目のシート名を「必ず」Sheet2に，３枚目のシート名を「必ず」Sheet3にします。それぞれのＣ列に会合名を記入します

シート１から３までの各シートのＤ２に
=SUMPRODUCT(COUNTIF(INDIRECT("Sheet"&ROW($B$1:$B$3)&"!B:B"),B2))
と記入，リスト下端までコピー
Ｄ列をオートフィルタで「２以上（１より大きい）」で絞り込み，コピーしてシート４に貼り付けていきます。

お礼

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

>>シート１から３までの各シートのＤ２に
>>=SUMPRODUCT(COUNTIF(INDIRECT("Sheet"&ROW($B$1:$B$3)&"!B:B"),B2))

こちらを実行させていただいたところ
D3に　'); } catch (error) {}
D4に　#REF!

と表示されるのみで、現段階ではそれ以上の対応に窮してしまいました。
まだ関数の理解が不十分なためいま一度よく調べてみようと思います。
ヒントをいただきありがとうございました。