エクセルで複数のシートからのデータ抽出

質問

いつも大変お世話になっております。

Sheet１、Sheet２に名簿１、名簿２が作成してあり、同一表中に同じ氏名や姓が同じで名前違いがあり、それぞれに同じまたは別のTELや住所等の付帯情報が入っています。

この2つのっｼｰﾄから、検索シートのＢ２セルに姓（例えば山本）だけを入れた場合に、山本を含む氏名の人の情報をリストにしたいのです。

複数シートのCOUNTIFとVLOOKUPで出来そうな気がしたのですが思うようにいかず。
どなたかHELPお願いします。

実際には製品名（シリーズの場合枝番が付いたりつかなかったり）で保管場所、容器サイズ、その他の情報をリストにするのが目的です。
つまり同じ製品名「A１２３」でもサイズ違いがあったり、保管場所が違ったり・・・をリストにしたいのです。

回答No.7

HohoPapa · ベストアンサー

列名、シート名を

＜ Const SelSQL1 = "SELECT [ﾗﾍﾞﾙ名] as [ﾗﾍﾞﾙ名] , [棚番号] as [棚番号] , [容量] as [容量] , [単位] as [単位] , [保有数量(L)] as [保有数量(L)]"＞

や

＜ SQL = SQL & "FROM [分①Tﾘｽﾄ$A5:Z50000]" & vbCrLf
＜ SQL = SQL & "FROM [分②Tﾘｽﾄ$A5:Z50000]" & vbCrLf

や

＜ SelKey = ThisWorkbook.Sheets("保管場所検索").Range("B2").Value＞

を元に合わせ、テストしてみましたが、
エラーを再現できません。

列の位置や並びは問いませんが
タイトル行の開始位置は添付画像のようになっていることが前提です。
異なるようであれば、合わせてみてください。

また、Officeのバージョンを教えてください。
加えて、ざっくりでいいのでデータの行数を教えてください。

お礼

週末から昨日迄休んでいて、本日朝一で確認したら、一杯のご回答を頂いておりビックリしています。

本件は正直1枚のシートに入力してしまえばフィルターで何とか目的は達成できる課題なのでこれほど多くのお手数をお掛けして、おまけに対応遅れで恐縮しています。

部署ごとにシートを分けた方が使い勝手が良いので、検索は何とかなると思い分割してしまったのですが・・・

多くのお手数をお掛けしてまでシートを分割するだけの価値があるのかどうか再度考えてみますので一旦締め切らせて頂きます。

多くのお知恵を頂き申し訳ありません。

補足

実際の内容で検証までしていただき恐縮至極です。
まさにこれがやりたいことです。（列違いの許容は毎度の忖度感心です）

当方も先ほどHohoPapaさんと同じ5列でリストシートは項目列４行、4行、検索シートのみ5行目で試してみたのですが何故か動かず。

もう一度最初からコードを確認してトライしてみますが一旦はここで締め切らせてもらいます。

本件元々1枚のシートで作業していたのを、検索は何とかなると思って気軽に2枚に分割したのが迂闊でした。（反省）

一旦元のシートを復活させますが、見本があるのでこれから粘って何とかしてみます。
知恵無き者汗を出せ！

ちなみに、
１．Officeのバージョンは2019で、
２．シートの行数は、現在200行と500行程度で今後はあまり増えないと思います。
古い製品は廃棄されて更新されていくので、今後増えても両方で1000行程度。

よってフィルターで何とかなる作業です。
実際には部署ごとに入力項目が違っているので、お互いに無駄な行が多く横に広がって少し面倒なのです・・・

本当に毎度お手数をお掛けしてばかりですが、年寄り（68歳）の我がままとご容赦願います。

回答No.12

kkkkkm

回答No.11の訂正です

何度も訂正すみません。

クリア範囲が間違ってました。

.Range(.Cells(5, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "F")).ClearContents

これだと何も転記されていない状態だと4行目の項目までクリアしてしまうので

.Range(.Cells(5, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row + 1, "F")).ClearContents

に変更してください。

また、蛇足の蛇足ですが

Ws3.Cells(LastRow + 1, "F").Value = WsD.Name

を

Ws3.Cells(LastRow + 1, "F").Formula = "=HYPERLINK(""#" & WsD.Name & "!A" & i & """,""" & WsD.Name & "!A" & i & """)"

にすると該当する元シートのデータ行にリンクで飛ぶことができます。

お礼

週末から昨日迄休んでいて、本日朝一で確認したら、一杯のご回答を頂いておりビックリしています。

本件は正直1枚のシートに入力してしまえばフィルターで何とか目的は達成できる課題なのでこれほど多くのお手数をお掛けして、おまけに対応遅れで恐縮しています。

部署ごとにシートを分けた方が使い勝手が良いので、検索は何とかなると思い分割してしまったのですが・・・

多くのお手数をお掛けしてまでシートを分割するだけの価値があるのかどうか再度考えてみますので一旦締め切らせて頂きます。

多くのお知恵を頂いたのですが、最初のご回答以外は未検証で本当に申し訳ありません。
これ以上の巻き込み被害を防止するために一旦締め切らせて頂きますのでご了承ください。

回答No.11

kkkkkm

回答No.8の追加訂正です。

D列への転記が抜けてました

' ws3.Cells(LastRow + 1, "A").Value = .Cells(i, "D").Value
' ws3.Cells(LastRow + 1, "B").Resize(1, 2).Value = .Cells(i, "B").Resize(1, 2).Value
' ws3.Cells(LastRow + 1, "E").Value = .Cells(i, "E").Value

を

' Ws3.Cells(LastRow + 1, "A").Value = .Cells(i, "D").Value
' Ws3.Cells(LastRow + 1, "B").Resize(1, 4).Value = .Cells(i, "B").Resize(1, 4).Value

に訂正

以下蛇足ですが、該当データの元のシート名をF列に記載したい場合は以下を追加してください。

Ws3.Cells(LastRow + 1, "F").Value = WsD.Name

と
検索シートのデータをクリアしている所

With Ws3
.Range(.Cells(5, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "E")).ClearContents
End With

をF列までにしてください。

With Ws3
.Range(.Cells(5, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "F")).ClearContents
End With

回答No.10

heisukewada

スマートではありませんが、
作業列に、連番を入れるVBAを書いてみました。
関数と比較するために7列目にしています。

Sub ふたつのシートの重複データに連番を入力する()

Dim cnt As Integer, i As Integer
Dim LastRows As Long
Dim Fname As String
Dim AWS As Worksheet
Dim Sh1max As Integer

'Sheet1をアクティブにする
Set AWS = Worksheets(1)
AWS.Activate

'最終行
LastRow = Cells(Rows.Count, 2).End(xlUp).Row

'連番を入れるセルをクリア
Range(Cells(3, 7), Cells(LastRow, 7)).ClearContents

'条件の文字列取得
Fname = Worksheets(3).Range("B2").Value

'連番用の変数の初期化
cnt = 0

'繰り返しの処理
For i = 3 To LastRow
If Cells(i, 2).Value Like Fname & "*" Then
cnt = cnt + 1
Cells(i, 7).Value = cnt
End If
Next i

'Sheet1の連番の最大値を求める
Sh1max = Application.WorksheetFunction.Max(Range(Cells(3, 7), Cells(LastRow, 7)))
'MsgBox Sh1max

'Sheet2をアクティブにする
Set AWS = Worksheets(2)
AWS.Activate

'最終行
LastRow = Cells(Rows.Count, 2).End(xlUp).Row

'連番を入れるセルをクリア
Range(Cells(3, 7), Cells(LastRow, 7)).ClearContents

'条件の文字列取得
Fname = Worksheets(3).Range("B2").Value

'連番用の変数の初期化
cnt = Sh1max

'繰り返しの処理
For i = 3 To LastRow
If Cells(i, 2).Value Like Fname & "*" Then
cnt = cnt + 1
Cells(i, 7).Value = cnt
End If
Next i

End Sub

お礼

週末から昨日迄休んでいて、本日朝一で確認したら、一杯のご回答を頂いておりビックリしています。

本件は正直1枚のシートに入力してしまえばフィルターで何とか目的は達成できる課題なのでこれほど多くのお手数をお掛けして、おまけに対応遅れで恐縮しています。

部署ごとにシートを分けた方が使い勝手が良いので、検索は何とかなると思い分割してしまったのですが・・・

多くのお手数をお掛けしてまでシートを分割するだけの価値があるのかどうか再度考えてみますので一旦締め切らせて頂きます。

お知恵を頂いたのに未検証のままで申し訳ありません。

回答No.9

kkkkkm

回答No.8の訂正です。

Ws3.Range(Cells(5, "A"), Cells(Ws3.Cells(Rows.Count, "A").End(xlUp).Row, "E")).ClearContents

はシートの指定が一部抜けていましたので以下に変更してください。

With Ws3
.Range(.Cells(5, "A"), .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "E")).ClearContents
End With

Sub Test()の最後に

Set Ws1 = Nothing
Set Ws2 = Nothing
Set Ws3 = Nothing

を追加しておいてください。

あと(山本を例にしますが)

氏と名の間にスペースがあるのでしたら

If .Cells(i, "B").Value Like Ws3.Range("B2").Value & "*" Then
を
If .Cells(i, "B").Value Like "*" & Ws3.Range("B2").Value & "*" Then
としておくと

山本 太郎
太郎 山本
ミラリッチ　山本　太郎

上記すべてを含めて転記します。

氏と名の間にスペースが無い場合後者にすると

田山本男

という人まで転記してしまいますので、状態に合わせて対応してください。

また、氏名の間にスペースが無く
太郎山本といった氏名が逆順の人がいる場合は

If .Cells(i, "B").Value Like Ws3.Range("B2").Value & "*" Or _
.Cells(i, "B").Value Like "*" & Ws3.Range("B2").Value Then

としておくと

山本太郎
太郎山本

両方対応できます。

回答No.8

kkkkkm

単純な以下で試してみてください

Sub Test()
Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet

Set Ws1 = Sheets("Sheet1")
Set Ws2 = Sheets("Sheet2")
Set Ws3 = Sheets("検索シート")

Ws3.Range(Cells(5, "A"), Cells(Ws3.Cells(Rows.Count, "A").End(xlUp).Row, "E")).ClearContents

Call DataPosting(Ws1, Ws3)
Call DataPosting(Ws2, Ws3)

End Sub

Function DataPosting(ByRef WsD As Worksheet, ByRef Ws3 As Worksheet)
Dim LastRow As Long
Dim i As Long, j As Long

With WsD
For i = 3 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(i, "B").Value Like Ws3.Range("B2").Value & "*" Then
LastRow = Ws3.Cells(Rows.Count, "A").End(xlUp).Row

'検索シートのNoが元のシートのNoの場合
Ws3.Cells(LastRow + 1, "A").Resize(1, 5).Value = .Cells(i, "A").Resize(1, 5).Value

'検索シートのNoが元のシートの住所(D列)を参照しているいたいですが、その場合は以下に

' ws3.Cells(LastRow + 1, "A").Value = .Cells(i, "D").Value
' ws3.Cells(LastRow + 1, "B").Resize(1, 2).Value = .Cells(i, "B").Resize(1, 2).Value
' ws3.Cells(LastRow + 1, "E").Value = .Cells(i, "E").Value

End If
Next
End With

End Function

お礼

たくさんのアイディアを頂き恐縮です。

No12にも記載しましたが、当初の見込み違いで私にはハードルが高い要求だったようです。

未検証のご回答に対し申し訳なく思いますがこれ以上はコスパが悪いので一旦締め切らせて頂きます。

何度もの追加回答本当に感謝！！

回答No.6

heisukewada

式をわかりやすくするために、作業列を設けてはどうでしょう？

名簿1のF3に
=IF(COUNTIF(B3,検索シート!$B$2&"*")>0,COUNTIF($B$3:B3,検索シート!$B$2&"*"),"")
下にオートフィル

名簿2のF3に
=IF(COUNTIF(B3,検索シート!$B$2&"*")>0,COUNTIF($B$3:B3,検索シート!$B$2&"*")+MAX(名簿１!F:F),"")
下にオートフィル

それでも長いですが、検索シートのB5に
=IFERROR(INDEX(名簿１!$B:$E,MATCH(ROW()-4,名簿1!$F:$F,0),MATCH(検索シート!B$4,名簿１!$2:$2,0)-1),IFERROR(INDEX(名簿２!$B:$E,MATCH(ROW()-4,名簿２!$F:$F,0),MATCH(検索シート!B$4,名簿１!$2:$2,0)-1),""))

下にオートフィル、右にオートフィル

補足
名簿１、２のF3は、検索シート！＄B$2&"*"　山本〇〇のワイルドカードが、そのままではIFの条件として使えないので、COUNTIF（）が　１になるか、0になるかの判断にしました。
検索シートのB５は、作業列の順位とマッチするように、ROW()で行番号を取得して、そこから４を引いて順位に合うようにしました。
名簿１と名簿２の検索結果をつなげるためにIFEROORを、使ってつなぎました。＃N/Aを、表示させないようにするために使うIFERRORを使いました。INDEX、MATCHは、名簿１も名簿２も、１か２がちがうだけで、同じ式です。
作業列は、列幅を非表示にすれば、見えなくなります。
表示させるときは、見えない列の左右の列をドラッグして、右クリックメニューから”再表示”をクリックすれば表示されます。

お礼

週末から昨日迄休んでいて、本日朝一で確認したら、一杯のご回答を頂いておりビックリしています。

私のやりたかったことはご回答の通りで最初は自分で関数を使って、と思ったのですが段々長くなってしまって最後は頭が錯綜してGive UPした次第です。
ご回答の関数が動くようにできる自信がありませんので一旦元のフィルターでの作業に戻そうかと・・・

本件は元々1枚のシートに入力していてフィルターで何とかしてた作業なのですが、お手数をお掛けしておまけに対応遅れで恐縮しています。

部署ごとにシートを分けた方が使い勝手が良いので、検索は何とかなると思い分割してしまったのですが・・・

多くのお手数をお掛けしてまでシートを分割するだけの価値があるのかどうか再度考えてみますので一旦締め切らせて頂きます。

回答No.5

HohoPapa

ごめんなさい、差し替えます。

VBAでよければ、後記コードはいかがでしょうか。

Sub sample()

　Const SelSQL1 = "SELECT [No] as [No] , [氏名] as [性] , [TEL] as [TEL] , [住所] as [住所] , [勤務先] as [勤務先]"
　Const SelSQL2 = "SELECT [No] as [No] , [性] as [性] , [TEL] as [TEL] , [住所] as [住所] , [勤務先] as [勤務先]"

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Dim ColCounter As Long
　Dim SelKey As String

　'SQL用環境設定
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name

　'抽出条件を取得
　SelKey = ThisWorkbook.Sheets("Sheet3").Range("B2").Value

　'SQLを組み立て
　SQL = "select *" & vbCrLf
　SQL = SQL & "from(" & vbCrLf
　SQL = SQL & SelSQL1 & vbCrLf
　SQL = SQL & "FROM [Sheet1$A2:Z50000]" & vbCrLf
　SQL = SQL & "union all" & vbCrLf
　SQL = SQL & SelSQL2 & vbCrLf
　SQL = SQL & "FROM [Sheet2$A2:Z50000]" & vbCrLf
　SQL = SQL & ")" & vbCrLf
　SQL = SQL & "Where" & vbCrLf
　SQL = SQL & " [性] LIKE '%" & SelKey & "%'" & vbCrLf

　'SQL全文を実行
　rs.Open SQL, cn

　'出力先をクリアー、列名出力、結果セットを一括出力
　With ThisWorkbook.Sheets("Sheet3")

　　.Rows("4:50000").Delete Shift:=xlUp
　　For ColCounter = 1 To rs.Fields.Count
　　　.Cells(4, ColCounter).Value = rs.Fields.Item(ColCounter - 1).Name
　　Next ColCounter
　　.Cells(5, 1).CopyFromRecordset rs
　End With

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

End Sub

補足

いつもお世話になっております。

早々に試してみましたが今まで見たことの無いエラーMsgが出ました。
「オートメーションエラー」「エラーを特定できません」
一応表の書式（列）は質問の表に合わせましたが、行数はどうしても合わせられないのでVBA中で変更してみたのですが・・・
表のA列に連番が入っているので、そのままとA列を削除した場合も試しましたが、同じMsgが表示されます。

当方で変更したコードは＜ ＞で囲んだ箇所です。
原因が推定できますでしょうか？

Sub 保管場所()

＜ Const SelSQL1 = "SELECT [ﾗﾍﾞﾙ名] as [ﾗﾍﾞﾙ名] , [棚番号] as [棚番号] , [容量] as [容量] , [単位] as [単位] , [保有数量(L)] as [保有数量(L)]"＞
＜ Const SelSQL2 = "SELECT [ﾗﾍﾞﾙ名] as [ﾗﾍﾞﾙ名] , [棚番号] as [棚番号] , [容量] as [容量] , [単位] as [単位] , [保有数量(L)] as [保有数量(L)]"＞

Dim SQL As String
Dim cn As Object
Dim rs As Object
Dim ColCounter As Long
Dim SelKey As String

'SQL用環境設定
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name

'抽出条件を取得
＜ SelKey = ThisWorkbook.Sheets("保管場所検索").Range("B2").Value＞

'SQLを組み立て
SQL = "select *" & vbCrLf
SQL = SQL & "from(" & vbCrLf
SQL = SQL & SelSQL1 & vbCrLf
＜ SQL = SQL & "FROM [分①Tﾘｽﾄ$A5:Z50000]" & vbCrLf
SQL = SQL & "union all" & vbCrLf＞
SQL = SQL & SelSQL2 & vbCrLf
＜ SQL = SQL & "FROM [分②Tﾘｽﾄ$A5:Z50000]" & vbCrLf
SQL = SQL & ")" & vbCrLf＞
SQL = SQL & "Where" & vbCrLf
＜SQL = SQL & " [ﾗﾍﾞﾙ名] LIKE '%" & SelKey & "%'" & vbCrLf＞

'SQL全文を実行
rs.Open SQL, cn

'出力先をクリアー、列名出力、結果セットを一括出力
＜With ThisWorkbook.Sheets("保管場所検索")＞

.Rows("4:50000").Delete Shift:=xlUp
For ColCounter = 1 To rs.Fields.Count
.Cells(4, ColCounter).Value = rs.Fields.Item(ColCounter - 1).Name
Next ColCounter
.Cells(5, 1).CopyFromRecordset rs
End With

'後処理
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing

End Sub

回答No.4

HohoPapa

VBAでよければ、後記コードはいかがでしょうか。

Sub sample()

　Const SelSQL1 = "SELECT [No] as [No] , [氏名] as [性] , [TEL] as [TEL] , [住所] as [住所] , [勤務先] as [勤務先]"
　Const SelSQL2 = "SELECT [No] as [No] , [性] as [性] , [TEL] as [TEL] , [住所] as [住所] , [勤務先] as [勤務先]"

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Dim ColCounter As Long
　Dim SelKey As String

　'SQL用環境設定
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open ThisWorkbook.Path & "\" & ThisWorkbook.Name

　'抽出条件を取得
　SelKey = ThisWorkbook.Sheets("Sheet3").Range("B2").Value

　'SQLを組み立て
　SQL = "select *" & vbCrLf
　SQL = SQL & "from(" & vbCrLf
　SQL = SQL & SelSQL1 & vbCrLf
　SQL = SQL & "FROM [Sheet1$A2:Z50000]" & vbCrLf
　SQL = SQL & "union all" & vbCrLf
　SQL = SQL & SelSQL2 & vbCrLf
　SQL = SQL & "FROM [Sheet2$A2:Z50000]" & vbCrLf
　SQL = SQL & "　　)" & vbCrLf
　SQL = SQL & "Where" & vbCrLf
　SQL = SQL & " [性] LIKE '%" & SelKey & "%'" & vbCrLf

　'SQL全文を実行
　rs.Open SQL, cn

　'出力先をクリアー、列名出力、結果セットを一括出力
　With ThisWorkbook.Sheets("Sheet3")

　　.Rows("4:50000").Delete Shift:=xlUp
　　For ColCounter = 1 To rs.Fields.Count
　　　.Cells(4, ColCounter).Value = rs.Fields.Item(ColCounter - 1).Name
　　Next ColCounter
　　.Cells(5, 1).CopyFromRecordset rs
　End With

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

End Sub

回答No.3

bunjii

>複数シートのCOUNTIFとVLOOKUPで出来そうな気がしたのですが思うようにいかず。
VLOOKUP関数で抽出するのは無理なのでINDEX関数とLARGE関数、COUNTIF関数の他幾つかの関数を組み合わせれば可能です。
Excel-2010で検証してみましたが（検索シート）のA列にあるNo.が提示の画像に符合できませんので他の項目のみでしたら下記の数式で対応できました。

Sheet3!B5セルへ数式を入力して右と下へオートフィルコピーしました。
=IFERROR(INDEX(Sheet1!$B$3:$E$22,LARGE(INDEX((FIND($B$2,Sheet1!$B$3:$B$22&$B$2)<LEN(Sheet1!$B$3:$B$22))*Sheet1!$A$3:$A$22,0),COUNTIF(Sheet1!$B$3:$B$22,$B$2&"*")-ROWS($5:5)+1),COLUMNS($B:B)),IFERROR(INDEX(Sheet2!$B$3:$E$22,LARGE(INDEX((FIND($B$2,Sheet2!$B$3:$B$22&$B$2)<LEN(Sheet2!$B$3:$B$22))*Sheet2!$A$3:$A$22,0),COUNTIF(Sheet2!$B$3:$B$22,$B$2&"*")-ROWS($5:5)+COUNTIF(Sheet1!$B$3:$B$22,$B$2&"*")+1),COLUMNS($B:B)),""))

Sheet3!のA列の条件を明示して頂ければ数式の修正を試してみます。

お礼

早々のご回答、それも大作をありがとうございます。

但し、当方のスキルとこれまでの実績？からこれを当方が動くように出来るまでには相当の時間が掛かる事は自信があります。

残念ですが如何ともしがたい現実とご提案の関数は諦めます。

補足

当初はもっと簡単に関数で出来ると思ったのですが。
最初に考えたのは、両方のシートのＡ列に通し番号（No）を振って氏名の一部を、
「No＆＊氏名＊」でVLOOKUPで引っ張ればできるのでは？
と思ったのですが、式が長くなってしまって（それでもご回答の半分以下程度）何度も最初からやり直したのですがうまく行かず。

連番だと２枚のシートにまたがるので、シート①とシート②でCOUNTIFで＊氏名＊の個数を連番にすれば出来る？とかトカ・・・

結局長い式には頭が付いて行かず断念した次第です。

回答No.2

imogasi

抽出という作業は、ExcelではVBAでやるほかないでしょう。関数では式が複雑になります。
また複数シートを対象に考えたくても、個別のシートの該当分が別々に出て、結果で同じものが両方に出る恐れがある。
第3の１シートにSheet１、Sheet２の２シートの各データをそれぞれコピペして（上行部分と下行部分とにコピしたものを張り付けて、一体化して、それを対象に、考えるべきでしょう（初心者は手作業が良い、VBAでもできるが）。
最低線は氏名列で、フリガナがあれば、それも含めたキーで、ソートすれば、同一名のはずで違う漢字などが、人間の目視チェックで、見つけられる。これをコンピュータだけでやろうとするのは、アルゴリズム的に無理でしょう。

お礼

確かに関数ではどんどん同じような式の追加で、どこに何を仕込んだのか頭が？？になって途中でHELPした次第です。

また、現在は手作業で処理しているので分かり易いのですが、操作でミス（抜け）があると結果の抽出表ではほとんどチェック不可能でトラブル必至。

ということでHELPしました。