【VBA】条件に一致するステータスの集計

Question

VBA初心者です。
ネットで「VBA条件一致」で検索して色々なものを見て自分なりにやってはいるのですが、
どうしても思い通りにいきません。
お助けいただけると嬉しいです。

＜やりたいこと＞
採用に繋がった「ステータス」の集計

例：新規⇒書類送付待ち⇒面接⇒選考中⇒採用済
という流れの場合、
「書類送付待ち」「面接」「選考中」にそれぞれカウント1をつける。

メールアドレスが一緒ならSheet1のB列、C列を見る。
C列が「採用済」になるまで見る。

C列が「採用済」だった場合、
これまで辿ってきたプロセス（ステータス前・後）を見て、
採用に繋がったものをSheet2のB列にカウントしていく、という手順になります。

※補足
・「採用済」になったメールアドレスは以降出てきません。
・「採用済」以外のメールアドレスは更新されます。
・添付例の黄色のメールアドレスのステータスで例えば「面接」は２件存在しますが
Sheet2へ加算するときは１件としてカウントします。

添付画像の左側がSheet1で、右側がSheet2です。

参考までに現在書いているコードです。
ArrayListがうまく使えずにいます。
そもそもコードが間違えているのか、別の問題なのかわからずにいます。
代替コードがあればご教授いただけると嬉しいです。

Sub saiyouritu()

'=====変数を宣言=====
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Rmax1 As Long
Dim Rmax2 As Long
Dim dicST_count As Object 'ステータス一覧　件数
Dim dicST_row As Object 'ステータス一覧　行番号
Dim dicML As Object 'メール一覧
Dim dicSY As Object '採用済の一覧
Dim dicW As Object 'ステータス作業用
Dim worw As Long
Dim key As Variant
Dim ArrList As Object 'ArrayList
Dim st1 As String
Dim st2 As String
Dim st As Variant

'=====定義をセット=====
Set dicST_count = CreateObject("Scripting.Dictionary") '連想配列の定義
Set dicST_row = CreateObject("Scripting.Dictionary") '連想配列の定義
Set dicML = CreateObject("Scripting.Dictionary") '連想配列の定義
Set dicSY = CreateObject("Scripting.Dictionary") '連想配列の定義
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")

'=====最終行を取得=====
Rmax1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row 'Sheet1のA列
Rmax2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row 'Sheet2のA列

'=====ステータスの行番号を登録=====
For wrow = 2 To Rmax2
key = ws2.Cells(wrow, "A")
dicST_row(key) = wrow
dicST_count(key) = 0
Next

'=====メアド一覧・ステータスを取得======
For worw = 2 To Rmax1
key = ws1.Cells(wrow, "A")
st1 = ws1.Cells(wrow, "B")
st2 = ws1.Cells(wrow, "C")
If dicML.Exists(key) = False Then
Set ArrList = CreateObject("System.Collections.ArrList")
dicML.Add key, ArrList
End If

dicML(key).Add ws1
dicML(key).Add ws2
    If ws2 = "採用済" Then
        dicSY(key) = True
    End If

Next

'=====採用済のメールのみ処理=====
For Each key In dicSY
Set ArrList = dicML(key)
Set dicW = CreateObject("Scripting.Dictionary")

'=====重複ステータスの削除=====
For Each st In ArrList
    dicW(st) = True
Next


    '=====ステータスの加算=====
    For Each st In dicW
        If dicST_count.Exists(st) = True Then
            dicST_count(st) = dicST_count(st) + 1
        Else
            MsgBox (st & "はSheet2に登録されていません")
        Exit Sub
        End If
    Next

Next

'=====Sheet2へ書き込み=====
For Each key In dicST_count
worw = dicST_row(key)
ws2.Cells(wrow, "B") = dicST_count(key)
Next

MsgBox ("完了")
End Sub

Comments

[cleaner]

条件が複雑過ぎると思います。どこで上手くいっていないのかもう少し問題を切り分けられないでしょうか？
例えばデバッグで一行ずつ進めるとどこでエラーが出ますか？
エラーがなく、思った通りにいかないというのであれば、データと結果を提示してもらうのが手っ取り早いと思います。
また、思ったとおりなりませんというのであれば丸投げの質問と見なされるかもしれません。
あと、コードはコードブロックに書いて下さい。

[退会済みユーザー]

[ 2021/02/15 14:54の投稿に対する言及]
「添付例の黄色のメールアドレスのステータスで例えば「面接」は２件存在しますが」というのは、「[e-mail]」はステータス(前)とステータス(後)の2列に亘って「面接」が2件ある、という事実についての言及でしょうか？
もしそうならば、「書類送付待ち」や「選考中」も「ステータス(前)とステータス(後)の2列に亘って2件ある」にもかかわらず、なぜ「面接」のみに対して言及されているのでしょうか。

そうではなくて、仮に、掲示している画像が誤りの場合、「同じメールアドレスの一連の動作の中で面接が2件あるパターン」を修正掲示してください。
画像のケースでは、すべてのメールアドレスについて、同じ行の「ステータス（前）」「ステータス（後）」をたどることで完全につなげられますが、未知の「同じメールアドレスで面接が2件」あるパターンでは、そうなっていない可能性があるからです。

[hatena19]

データに「連絡済み」「連絡済」などの表記ブレがありますが、実際のデータにもありますか。その場合、事前に表示ブレを修正する必要がありますね。
また、データは時系列順に並んでいるということでよろしいですか。

[tatsu99]

このコードは、教えてgooの
https://oshiete.goo.ne.jp/qa/12202044.html
で私が回答したものです。
もし、問題があるなら、なぜ、そのスレッドで問題があると、返信しないのでしょうか。
なお、ArrayListは、Macでは使用できません。

[退会済みユーザー]

>tatsu99さん
お疲れ様です。

tatsu99さんがおしえてgooで回答したコードと、質問者のコードをdiffに掛けてみましたが、
・変数を単純に置き換え（しかも、わかりやすい名前に変えたとかではなく、st2→sh2のような形）
・いくつかのcellに.valueを付けるだけ
・いくつかのコメントを省略している
だけでプログラムの流れの部分は全く同じでした。

また変数の置換そのものに関してミスしている部分があり、一部の動作がおかしくなっている（セルの内容を入れないといけないのに、シートオブジェクトを代入する動作になっている等）ので、動作確認もしていないと推測されます。

変数の置換ミスってことは目視で置き換えたんでしょうかね。

＞質問者殿
どういう意図で、ここまで手をかけてまでソースを改変して投稿したのかはわかりかねますが、マルチポストはやめましょう。

百歩譲っても、他人が汗水たらして考えてくれたコードを、さも自分が考えたコードであるかのように誤認させる形で投稿するのはどうかと思います。

（「色々なものを見て自分なりにやってはいる」「参考までに現在書いているコードです」という表現）

Answer 1

こんな感じでいかがでしょうか。

Sub saiyouritu2()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet

    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")

    Dim d As Object
    Dim c As Range
    Dim v As Variant

    Set d = CreateObject("Scripting.Dictionary")

    For Each c In ws1.UsedRange.Columns(1).Cells

        If Not d.Exists(c.Value) Then d.Add c.Value, CreateObject("Scripting.Dictionary")
        d(c.Value)(c.Offset(, 1).Value) = 0
        d(c.Value)(c.Offset(, 2).Value) = 0


        If c.Offset(, 2).Value = "採用済" Then
            For Each v In d(c.Value).Keys
                If WorksheetFunction.CountIf(ws2.Columns(1), v) = 0 Then
                    MsgBox v & "はSheet2に登録されていません"
                    Exit Sub
                End If
                With ws2.Cells(WorksheetFunction.Match(v, ws2.Columns(1), False), 2)
                    .Value = .Value + 1
                End With
            Next
        End If
    Next
    MsgBox "完了"
End Sub

---

＜追記＞
上記は元のコードをあまり読まずに自分の手癖で書きました。
でも、結果的に似たような感じになりましたね。
いくつかのスペルミスらしきものを修正してみました。

Sub saiyouritu()

'=====変数を宣言=====
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Rmax1 As Long
Dim Rmax2 As Long
Dim dicST_count As Object  'ステータス一覧　件数
Dim dicST_row As Object  'ステータス一覧　行番号
Dim dicML As Object         'メール一覧
Dim dicSY As Object         '採用済の一覧
Dim dicW As Object         'ステータス作業用
Dim wrow As Long
Dim key As Variant
Dim ArrList As Object       'ArrayList
Dim st1 As String
Dim st2 As String
Dim st As Variant

'=====定義をセット=====
Set dicST_count = CreateObject("Scripting.Dictionary")  '連想配列の定義
Set dicST_row = CreateObject("Scripting.Dictionary")   '連想配列の定義
Set dicML = CreateObject("Scripting.Dictionary")   '連想配列の定義
Set dicSY = CreateObject("Scripting.Dictionary")    '連想配列の定義
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")

'=====最終行を取得=====
Rmax1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row    'Sheet1のA列
Rmax2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row    'Sheet2のA列

'=====ステータスの行番号を登録=====
For wrow = 2 To Rmax2
key = ws2.Cells(wrow, "A")
dicST_row(key) = wrow
dicST_count(key) = 0
Next

'=====メアド一覧・ステータスを取得======
For wrow = 2 To Rmax1
key = ws1.Cells(wrow, "A")
st1 = ws1.Cells(wrow, "B")
st2 = ws1.Cells(wrow, "C")
If dicML.Exists(key) = False Then
Set ArrList = CreateObject("System.Collections.ArrayList")
dicML.Add key, ArrList
End If

dicML(key).Add st1
dicML(key).Add st2
If st2 = "採用済" Then
dicSY(key) = True
End If
Next

'=====採用済のメールのみ処理=====
For Each key In dicSY
Set ArrList = dicML(key)
Set dicW = CreateObject("Scripting.Dictionary")

'=====重複ステータスの削除=====
For Each st In ArrList
dicW(st) = True
Next

'=====ステータスの加算=====
For Each st In dicW
If dicST_count.Exists(st) = True Then
dicST_count(st) = dicST_count(st) + 1
Else
MsgBox (st & "はSheet2に登録されていません")
Exit Sub
End If
Next
Next

'=====Sheet2へ書き込み=====
For Each key In dicST_count
wrow = dicST_row(key)
ws2.Cells(wrow, "B") = dicST_count(key)
Next

MsgBox ("完了")
End Sub