エクセルＶＢＡ 重複を表示したい2

質問

エクセルＶＢＡ　重複を表示したい2
以下ではたいへんお世話になりありがとうございました。
http://okwave.jp/qa/q5849885.html

上記に関連する質問をさせていただきます。
下記に提示したコードを修正して、以下のようなコードに変えたいと考えています。
「Ｂ列で重複したデータがあれば、そのすべてを左隣のデータと一緒に表示したい」
添付した図だと、
1小沢一郎
7〃
8〃
4鈴木一郎
6〃
以上のような感じです。
アドバイスよろしくお願いします。

Sub TEST()
Dim myRange As Range
Dim 同一flag As Boolean
Dim MsgStr As String
m_Rows = Range("b" & Rows.Count).End(xlUp).Row
For Each myRange In Range("b2:b" & m_Rows)
If WorksheetFunction.CountIf(Range("b2:b4000"), myRange) > 1 Then
If 同一flag = False Then 同一flag = True
If InStr(1, MsgStr, myRange) = 0 Then
MsgStr = MsgStr & myRange.Offset(0, -1).Value & myRange & vbCrLf
End If
End If
Next
If 同一flag = True Then
MsgBox "同姓同名あり" & Chr(13) & _
"確認してください" & Chr(13) & _
vbCrLf & MsgStr
Else
End If
End Sub

回答No.4

keithin · ベストアンサー

sub macro2r1()
　dim h as range
　dim target as range
　dim res as string

　application.screenupdating=false
　range("A:B").sort key1:=range("B1"), order1:=xlascending, header:=xlyes, sortmethod:=xlstroke

　set target = range("B2:B" & range("B65536").end(xlup).row)

　for each h in target
　　if application.countif(target, h)> 1 then
　　　res = res & vbcr & h.offset(0, -1) & h
　　end if
　next

　range("A:B").sort key1:=range("A1"), header:=xlyes
　application.screenupdating=true

　if res <> "" then
　　msgbox "found" & vbcr & res
　end if
end sub

こちらも実際のデータが例示されたようでは無い時は，まだおかしい結果になるかもしれません。
もう一手間マクロの中で，現状復元用の正しい連番を追記させた方が安全は安全です。たいした手間ではないので，自力で出来ると思います。

＞Ａ列＝Ｂ列でない場合も下記のように表示してしまいます。

言葉は間違っているようですが意味は分かると思います。が，あり得ない間違いです。
回答のマクロをコピーし損ねたか，何か他のマクロと勘違いしたのでは？

お礼

度々のご回答ありがとうございます。
希望どおりにうまく反応しました。
お世話になりました。

＞Ａ列＝Ｂ列でない場合も下記のように表示してしまいます。
すみません。表現が間違っていました。
具体的には、
鈴木一郎山口
鈴木一郎岐阜
上記のようにＢ列が異なってもＡ列が同一だと表示されてしまいます。

回答No.6

Wendy02

関数なら、以下のようにして出来ます。(2～101行目までのデータの場合)

D1:～
=SMALL(INDEX((COUNTIF($B$2:$B$101,$B$2:$B$101)>1)*ROW($A$1:$A$100),,),ROW(A1)+ROWS($A$1:$A$100)-SUMPRODUCT((COUNTIF($B$2:$B$101,$B$2:$B$101)>1)*1))

E1:～
=IF(D1<>0,INDEX($B$2:$B$101,D1,),"")

ワークシート関数を使わずに、ソートアルゴリズムを使って作ってみました。
なるべく検索部分にはワークシート関数を使わないほうが移植性が高いので作り直しました。（#2は、バグがありました)

Public Sub FindDouble()
'ソートプログラムを使用する
Dim msg As String
Dim buf As String, buf1 As String, buf2 As String
Dim a As Variant, b As Variant, ar3 As Variant
Dim L As Long, N As Long
Dim i As Long
Dim R As Long
Dim t1 As Variant, t2 As Variant
Dim Shift As Long
Dim rng As Range

Set rng = Range("A2", Cells(Rows.Count, 1).End(xlUp))
N = rng.Rows.Count + 1
a = Application.Transpose(rng.Offset(, 1).Value)
b = Application.Transpose(rng.Value)
L = 1: R = N - 1
Do While L < R
　　For i = L To R - 1
　　　　If Trim(a(i)) > Trim(a(i + 1)) Then
　　　　　　t1 = a(i): a(i) = a(i + 1): a(i + 1) = t1
　　　　　　t2 = b(i): b(i) = b(i + 1): b(i + 1) = t2
　　　　　　Shift = i
　　　　End If
　　Next i
　　R = Shift
　　For i = R To L + 1 Step -1
　　　　If Trim(a(i)) < Trim(a(i - 1)) Then
　　　　　　t1 = a(i): a(i) = a(i - 1): a(i - 1) = t1
　　　　　　t2 = b(i): b(i) = b(i - 1): b(i - 1) = t2
　　　　　　Shift = i
　　　　End If
　　Next i
　　L = Shift
Loop
For i = 1 To UBound(a) - 1
　　If (a(i)) = a(i + 1) Then
　　　　If buf = "" Then
　　　　　　buf = b(i) & ": " & a(i) & vbCrLf & b(i + 1) & ": " & "〃"　'a(i + 1)
　　　　Else
　　　　　　buf = buf & vbCrLf & b(i + 1) & ": " & "〃"　 'a(i + 1)
　　　　End If
　　ElseIf buf <> "" Then
　　　　msg = msg & vbCrLf & Mid(buf, 1)
　　　　buf = ""
　　End If
Next i
If buf <> "" Then msg = msg & vbCrLf & Mid(buf, 1)
MsgBox msg
ar3 = Split(msg, vbCrLf)
For i = LBound(ar3) To UBound(ar3)
　　If ar3(i) <> "" Then
　　　　Cells(i, 6).Resize(, 2).Value = Split(ar3(i), ": ")
　　End If
Next
End Sub

お礼

度々のご回答、アドバイスありがとうございます。

回答No.5

keithin

＞すみません。表現が間違っていました。
　：
＞上記のようにＢ列が異なってもＡ列が同一だと表示されてしまいます。

表現が間違っていることも，あなたがこういう具合に違っていると主張されている内容も，いずれもちゃんと判っていますと先の回答でお答え済みです。

それであんまり無駄な投稿はしたくありませんが，あなたも自分の説明が間違ってないと言い張るように，私の方もそんな無様なミスは犯しませんと申し上げなければなりません。

前回いただいたコメントは
＞ご教授いただいたコードだとＢ列が空白でも表示されてしまいます。

のようでしたが，今回お話しいただいた(正しい)内容ともまた食い違っています。

そういった具合にご説明に言い間違いが散見されたり，こうだという内容に色々とブレがある事，またそもそもあなたのおっしゃる不具合が私の回答マクロでは起こらないことから，あなたは何か間違ったコードを見て私からの回答マクロが「できない」と勘違いされているご様子です。

お礼

>あなたは何か間違ったコードを見て私からの回答マクロが「できない」と勘違いされているご様子です。
おっしゃるとおり私の誤りでした。

度々のご回答をいただいた上に、貴方様の名誉を損ねるような書き込みをしてしまいました。
誠に申し訳ありませんでした。
今後は十分に注意致します。

回答No.3

myRange

コードの勉強のためなら何ですが、実際の業務でこのコードを使うなら、
Wendy02さんも指摘されてるように別のセルに書き出すべきです。
MsgBoxに表示すると実際に目でチェックするとき困りませんか？
目でチェックする段階ではMsgBoxを消さないといけないわけですから、
結果を全て頭に入れておくか、メモしとかないといけませんよね。
そしてまた、ダブりが１００件あったら？？？？

で、別セル（Ｄ，Ｅ列）に結果を書き出すということで
質問者のコードを修正加筆すると、、、、

'----------------------------------------------
Sub TEST()
　Dim Rng As Range
　Dim myRange As Range
　Dim MsgStr As String
　Dim m_Rows As Long
　Dim Cnt As Long

　Range("D:E").Clear
　Range("D1:E1").Value = Array("番号", "名前")
　Cnt = 1

　m_Rows = Range("b" & Rows.Count).End(xlUp).Row
　Set myRange = Range("B2", Cells(m_Rows, "B"))

　For Each Rng In myRange
　　　If WorksheetFunction.CountIf(myRange, Rng.Value) > 1 Then
　　　　　　Cnt = Cnt + 1
　　　　　　Cells(Cnt, "D").Value = Rng.Offset(0, -1).Value
　　　　　　Cells(Cnt, "E").Value = Rng.Value
　　　End If
　Next

　If Cnt > 1 Then
　　　Range("D1", Cells(Cnt, "E")).Sort _
　　　　　　Key1:=Range("E2"), Order1:=xlAscending, _
　　　　　　Key2:=Range("D2"), Order2:=xlAscending, _
　　　　　　Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
　　　　　　Orientation:=xlTopToBottom, SortMethod:=xlPinYin
　　　MsgBox "Ｄ，Ｅ列に、ダブりを表示しました " & vbLf & vbLf & _
　　　　　　　"確認してください", vbInformation + vbOKOnly, "ダブりチェック"
　Else
　　　MsgBox "ダブりはありません", vbOKOnly, "ダブりチェック"
　End If
End Sub
'------------------------------------------------------

Ｓｏｒｔをしない方法もありますが、
それは、も少しＶＢＡに慣れてからということで。。。。
以上です。

お礼

ご回答ありがとうございます。
＞MsgBoxに表示すると実際に目でチェックするとき困りませんか？
おっしゃるとおりですね。
たいへん、勉強になりました。

回答No.2

Wendy02

>提示したコードを修正して
それは無理です。とても、修正できるものではありません。
以下は、Excel独特の尺取虫の検索です。ダブリが多いようなら、セルに書き出してください。
B列を並べ替えてはじき出すか、関数を利用するか、ソートアルゴリズムも可能です。なるべく自分で解決する方法を見つけてください。
'--
Sub SearchMcr()
　　Dim ar As Variant, ar2 As Variant
　　Dim rng As Range
　　Dim arNum() As Variant
　　Dim arName() As Variant
　　Dim ret As Variant, ret2 As Variant
　　Dim i As Long, j As Long
　　Dim n As Long
　　Dim msg As String
　　'-
　　'最初の場所
　　Set rng = Range("B2", Cells(Rows.Count, 2).End(xlUp))
　　'-
　　ar = Application.Transpose(rng.Value)
　　ar2 = Application.Transpose(rng.Offset(, -1).Value)
　　For i = LBound(ar) To UBound(ar) - 1
　　　　For j = i + 1 To UBound(ar)
　　　　　　With rng
　　　　　　　　If Trim(ar(i)) <> "" Then
　　　　　　　　　　If i > 1 Then
　　　　　　　　　　　　ret = Application.Match(ar(i), arName, 0)
　　　　　　　　　　　　If IsNumeric(ret) Then
　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　　　ret = Application.Match(ar(i), Range(.Cells(j, 1), .Cells(.Cells.Count)), 0)
　　　　　　　　　　If IsNumeric(ret) Then
　　　　　　　　　　　　ReDim Preserve arNum(n)
　　　　　　　　　　　　ReDim Preserve arName(n)
　　　　　　　　　　　　ret2 = Application.Match(ar(i), arName, 0)
　　　　　　　　　　　　If IsNumeric(ret2) Then
　　　　　　　　　　　　　　arName(n) = "〃"
　　　　　　　　　　　　　　arNum(n) = ar2(ret + j - 1)
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　arNum(n) = ar2(i)
　　　　　　　　　　　　　　arName(n) = ar(i)
　　　　　　　　　　　　　　n = n + 1
　　　　　　　　　　　　　　ReDim Preserve arNum(n)
　　　　　　　　　　　　　　ReDim Preserve arName(n)
　　　　　　　　　　　　　　arNum(n) = ar2(ret + j - 1)
　　　　　　　　　　　　　　arName(n) = "〃"
　　　　　　　　　　　　End If
　　　　　　　　　　　　n = n + 1
　　　　　　　　　　　　j = ret + j
　　　　　　　　　　Else
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End With
　　　　Next
　　Next
　　For i = LBound(arName) To UBound(arName)
　　　　If msg <> "" Then
　　　　　　If arNum(i - 1) > arNum(i) Then
　　　　　　　　msg = msg & vbCrLf & String(6, "-")
　　　　　　End If
　　　　End If
　　　　msg = msg & vbCrLf & arNum(i) & ": " & arName(i)
　　Next
　　MsgBox msg
'書き出す場合
'Range("G1").Resize(n).Value = Application.Transpose(arNum)
'Range("H1").Resize(n).Value = Application.Transpose(arName)
End Sub

お礼

度々のご回答ありがとうございます。
＞なるべく自分で解決する方法を見つけてください。
私には高レベルなコードなので連休中、学習します。

回答No.1

keithin

sub macro2()
　dim h as range
　dim target as range
　dim res as string

　set target = range("B2:B" & range("B65536").end(xlup).row)

　for each h in target
　　if application.countif(target, h)> 1 then
　　　res = res & vbcr & h.offset(0, -1) & h
　　end if
　next

　if res <> "" then
　　msgbox "found" & vbcr & res
　end if
end sub

＃前回のご相談ではオリジナルのご相談に書かれていない詳細不明の「空白」が何か悪さをしていたらしいですが，手元で幾つかサンプルデータを想定してみましたけどあなたの失敗を再現できませんでした。変な格好で入っていたデータが悪さをしていたのじゃないでしょうかと思います。

お礼

いつも迅速なご回答ありがとうございます。
もし可能なら、下記のように同一人物は続けて表示できないでしょうか？
1小沢一郎
7小沢一郎
8小沢一郎
よろしくお願いします。

＞変な格好で入っていたデータが悪さをしていたのじゃないでしょうかと思います。
ご提示いただいたコードだとＡ列＝Ｂ列でない場合も下記のように表示してしまいます。
鈴木一郎山口
鈴木一郎岐阜