1列目と２列目で一致した文字列があった場合の、一致した回数を変数に格納する方法

投稿者 : 初心者     投稿日時 : 2024/07/06(Sat) 23:06:38     OS : Windows 10     EXCEL : Excel 2019

---

どなたかご助力いただけると幸いです。
・作業するシート（例）　
A列　　　B列
田中　　田中
田中　　田中
鈴木　　吉田
鈴木　　吉田
木村　　上村
木村　　上村
東　　　木村
東　　　木村
上村
上村

シート名：判定シート

・やりたいこと
A列とB列で同一の名前が登場する回数をカウントしたい。ただし、同じ名前が２回連続で記入されているが、それはカウントしない。
例えば上の表で行くと、田中、上村、木村がかぶっているので、３という数字を取得したい。
名前の種類や行数は作業する月によってランダムに変化する。

・現状

Sub 判定()

Dim 判定シート As Worksheet
Set 判定シート = Worksheets("判定")

Dim 最終行1 As Long
Dim 最終行2 As Long
最終行1 = Cells(Rows.Count, 1).End(xlUp).Row
最終行2 = Cells(Rows.Count, 2).End(xlUp).Row

Dim 一致数 As Integer
一致数 = 0

Dim k As Long
Dim k2 As Long

For k = 1 To 最終行1
    For k2 = 1 To 最終行2
        If 判定シート.Cells(k, 1) = 判定シート.Cells(k2, 2) Then
        一致数 = 一致数 + 1
        End If
    Next
Next

判定シート.Range("G4") = 一致数

End Sub

このコードでは、一致数が０になってしまいます…。
おそらく、for NEXT の入れ子構造が誤っていると思うのですが、アドバイスいただけないでしょうか。

投稿者 : さんこう     投稿日時 : 2024/07/06(Sat) 23:54:38

---

＞このコードでは、一致数が０になってしまいます…。

シート「判定」がアクティブな状態で実行すれば、G4セルには「12」と表示されます。


＞おそらく、for NEXT の入れ子構造が誤っていると思うのですが、アドバイスいただけないでしょうか。

重複を排除できていませんがカウントはされているので、別の問題があるのでしょう。

もっとも、FindとかMatchとかWorksheetFunction.CountIfなどを使うほうが簡単だと思いますが。

投稿者 : てらてら     投稿日時 : 2024/07/07(Sun) 06:08:15

---

こんにちは。

　A列の重複もカウントしないのであれば、A列要素の重複しないリストが必要になると思います。
　B列との重複は、見つかった時点でFor文を抜ければOKでしょう。

　A列の重複しないリストは、Rangeから配列を作って、重複要素を空白に書き換えています。
　（手抜きです。）

Sub 判定()

    Dim 判定シート As Worksheet
    Set 判定シート = ActiveSheet 'Worksheets("判定")
    
    Dim 最終行1 As Long
    Dim 最終行2 As Long
    最終行1 = Cells(Rows.Count, 1).End(xlUp).Row
    最終行2 = Cells(Rows.Count, 2).End(xlUp).Row
    
    'A列の重複しない配列を作る（空白要素付き）
    Dim i As Long, j As Long, cnt As Long
    Dim arr
    
    arr = Range("A1:A" & 最終行1)
    cnt = 2
    For i = 1 To 10
        For j = cnt To 10
            If arr(i, 1) <> "" And arr(i, 1) = arr(j, 1) Then
                arr(j, 1) = ""
            End If
        Next j
        cnt = cnt + 1
    Next i
    
    
    Dim 一致数 As Integer
    一致数 = 0
    
    Dim k As Long
    Dim k2 As Long
    
    For k = 1 To 最終行1
        If arr(k, 1) <> "" Then
            For k2 = 1 To 最終行2
                If arr(k, 1) = 判定シート.Cells(k2, 2) Then
                    一致数 = 一致数 + 1
                    Exit For    '<---追加
                End If
            Next
        End If
    Next
    
    判定シート.Range("G4") = 一致数

End Sub

投稿者 : ピロリ     投稿日時 : 2024/07/07(Sun) 07:55:29

---

ネックは、｢田中｣さんが 既に処理済か否かを判定するところかと思います。
↓は手抜きですが、Findメソッドを使う案です。　参考になるか分かりませんが･･･

Sub 判定2()
    Dim 判定シート As Worksheet
    Set 判定シート = Worksheets("判定")
    With 判定シート
        .Columns("C:C").Insert                          'C列を間借りさせていただいて･･･
        
        Dim k As Long, 一致数 As Long
        一致数 = 0
        For k = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
            If Not .Columns("B:B").Find(.Cells(k, "A"), LookAt:=xlWhole) Is Nothing And _
                   .Columns("C:C").Find(.Cells(k, "A"), LookAt:=xlWhole) Is Nothing Then
                                                'B列に有って(重複)、C列に無い(処理済でない)なら、
                一致数 = 一致数 + 1                     '一致数を更新して、
                .Cells(一致数, "C") = .Cells(k, "A")    '間借りしたC列へ処理済として名前を記録
            End If
        Next k
        .Columns("C:C").Delete                          'C列は用済みになったので削除して･･･
        .Range("G4") = 一致数                           '一致数を出力
    End With
End Sub

投稿者 : 初心者     投稿日時 : 2024/07/07(Sun) 08:13:35

---

ご丁寧にありがとうございます。
配列を修正&forを抜ける旨、よくわかりました。
ただ、お恥ずかしながら知識がない故、

'A列の重複しない配列を作る（空白要素付き）
Dim i As Long, j As Long, cnt As Long
Dim arr

arr = Range("A1:A" & 最終行1)
cnt = 2
For i = 1 To 10
For j = cnt To 10
If arr(i, 1) <> "" And arr(i, 1) = arr(j, 1) Then
arr(j, 1) = ""
End If
Next j
cnt = cnt + 1
Next i

この辺りが何を意味するのかいまいち飲み込めませんでした。

オブジェクト変数をrang型で宣言し、
arr = Range("A1:A" & 最終行1)
としたときの
arr(i, 1)
は何を表すのか、また、

If arr(i, 1) <> "" And arr(i, 1) = arr(j, 1) Then
arr(j, 1) = ""
End If
ここの条件式の意味

を、教えていただけないでしょうか。
お手数おかけします。

投稿者 : てらてら     投稿日時 : 2024/07/07(Sun) 11:39:57

---

今回のプログラムの場合、A列のリストから重複しないリストを作るのがミソになると思います。

「重複しないリスト」を作るというのは、いくつが種類があるのですがどれも初心者には厄介なコードになってしまいます。
例としては、辞書を使う、別のRangeにコピーして重複の削除コマンドを使う、動的配列で重複しないように作っていくなどです。

今回私が提示したのは、Rangeを配列に突っ込む方法です。
（すみません。10 は、間違いです。最終行1 に変更してください。）

>arr = Range("A1:A" & 最終行1)
>cnt = 2
>For i = 1 To 最終行1 '<--ここは10ではなく、最終行1　の間違い
>For j = cnt To 最終行1 '<--ここは10ではなく、最終行1　の間違い

Rangeを arr に突っ込むと、一列でも二次配列になってしまいます。
つまり、
arr(1,1) = "田中"
arr(2,1) = "田中"
arr(3,1) = "鈴木"
arr(4,1) = "鈴木"
arr(5,1) = "木村"
arr(6,1) = "木村"
,
,

となります。

その後の2重のFor文では、同じ配列の値同士をすり合わせながら同じ場合は、2回目以降を空白にしていきます。

arr(1,1) = "田中"
arr(2,1) = ""
arr(3,1) = "鈴木"
arr(4,1) = ""
arr(5,1) = "木村"
arr(6,1) = ""
,
,

こんな感じの配列に変わります。

●を付けたあたりにブレークポイントを設置してステップ実行しなら、ローカルウインドウを観察すれば何をしているかわかると思います。

これで重複していた所は空白に変わるので、空白以外の値は重複していない事になり、B列と比べます。

再掲します。

Sub 判定()

    Dim 判定シート As Worksheet
    Set 判定シート = Worksheets("判定")
    
    Dim 最終行1 As Long
    Dim 最終行2 As Long
    最終行1 = Cells(Rows.Count, 1).End(xlUp).Row
    最終行2 = Cells(Rows.Count, 2).End(xlUp).Row
    
    'A列の重複しない配列を作る（空白要素付き）
    Dim i As Long, j As Long, cnt As Long
    Dim arr
    
    arr = Range("A1:A" & 最終行1)
    cnt = 2
    For i = 1 To 最終行1    '●
        For j = cnt To 最終行1
            If arr(i, 1) <> "" And arr(i, 1) = arr(j, 1) Then
                arr(j, 1) = ""
            End If
        Next j
        cnt = cnt + 1
    Next i
    
    Dim 一致数 As Integer
    一致数 = 0
    
    Dim k As Long
    Dim k2 As Long
    
    For k = 1 To 最終行1
        If arr(k, 1) <> "" Then
            For k2 = 1 To 最終行2
                If arr(k, 1) = 判定シート.Cells(k2, 2) Then
                    一致数 = 一致数 + 1
                    Exit For    '<---追加
                End If
            Next
        End If
    Next
    
    判定シート.Range("G4") = 一致数

End Sub

投稿者 : てらてら     投稿日時 : 2024/07/07(Sun) 11:42:07

---

A列を加工してもいいならもっと簡単に書けます。

Sub 判定2()

    Dim 判定シート As Worksheet
    Set 判定シート = Worksheets("判定")
    
    Dim 最終行1 As Long
    Dim 最終行2 As Long
    最終行1 = Cells(Rows.Count, 1).End(xlUp).Row
    最終行2 = Cells(Rows.Count, 2).End(xlUp).Row
    
    'A列の重複しない配列を作る（重複の削除コマンドでA列加工）
    判定シート.Range("A1:A" & 最終行1).RemoveDuplicates Columns:=1, Header:=xlNo
    最終行1 = Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim 一致数 As Integer
    一致数 = 0
    
    Dim k As Long
    Dim k2 As Long
    
    For k = 1 To 最終行1
        For k2 = 1 To 最終行2
            If 判定シート.Cells(k, 1) = 判定シート.Cells(k2, 2) Then
                一致数 = 一致数 + 1
                Exit For    '<---追加
            End If
        Next
    Next
    
    判定シート.Range("G4") = 一致数

End Sub