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

Question

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

tom04 · Accepted Answer

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

bunjii · Answer

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

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

bunjii · Answer

>この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),"○","")

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

tom04 · Answer

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

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

keithin · Answer

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

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

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

No.2です。

>こちらを試してみたところ

>このSheet4のように重複している名前とシート名が分かる形で抽出できないでしょうか？

こんばんは！

この回答への補足

１枚目のシート名を「必ず」Sheet1にします。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング