VBA 照合カウント計算 その2

Question

前提

●転記元
シート1

●転記先※完成状態
シート2

●転記先※完成状態
シート3

ここに質問の内容を詳しく書いてください。
（例）
TypeScriptで●●なシステムを作っています。
■■な機能を実装中に以下のエラーメッセージが発生しました。

実現したいこと

以下ＶＢＡを作成しました。
今後データが多くなる為現状のやり方の場合動作が遅くなる恐れがある為、
配列等を用いて処理速度が速いプログラムを作成したいのですが、
方法がさっぱり分からない為、作成方法を教えていただきたいです。

転記元excelの共通ｷｰと転記先excelを部分照合し、数値をｶｳﾝﾄ計算
①転記元excelのC列（Ｃ12〜Ｃ1300）と転記先excelのA列（Ａ2〜Ａ366）を照合して以下処理を実行
合致：合致年月のＤ列（Ｄ12〜）でｾﾙ値有無ﾁｪｯｸ
空白の場合：ｾﾙへ1記入
空白でない場合：+1ｶｳﾝﾄ
不一致：処理を飛ばす
上記サイクルを以下ステップで繰り返す。
ステップ②
シート1　　　　　シート2　　　シート2　　
照合　　　　　　　照合　　　　　セル入力
転記元：Ｄ列　→　転記先：Ａ　→転記先：Ｅ列
転記元：Ｅ列　→　転記先：Ａ　→転記先：Ｆ列
転記元：Ｆ列　→　転記先：Ａ　→転記先：Ｇ列
ステップ③
シート1　　　　　シート3　　　シート3
転記元：B列　→　転記先：Ａ　→転記先：B列

該当のソースコード

Sub 照合転記()
Const source As String = "C:\Users\xxx\Desktop\yy\00_VBA\照合転記2" '転記元パス
Const copy As String = "C:\Users\xxx\Desktop\yy\00_VBA\照合転記2"
Const cn As String = "転記先.xlsx"
Dim sslastline As String '転記元A最終行
Dim shlastline As String '転記元B最終行
Dim sklastline As String '転記先C最終行
Dim ssylastline As String '転記元D最終行
Dim ssyylastline As String '転記元E最終行
Dim clastline As String '転記先日付最終行

Dim sWb As Workbook '転記元ファイル変'
Dim sWs As Worksheet '転記元ファイル変数
Dim cWb As Workbook '転記先ファイル変数
Dim cWs As Worksheet '転記先シート変数
Dim cWs1 As Worksheet '転記先製作指示台数シート変数
Dim a As Integer 'A繰返し回数
Dim b As Integer 'B繰返し回数
Dim c As Integer 'C繰返し回数
Dim d As Integer 'D繰返し回数
Dim e As Integer 'E繰返し回数

Dim sresult As String 'A検索キー
Dim hresult As String 'B検索キー
Dim kresult As String 'C検索キー
Dim syresult As String 'D検索キー
Dim syyresult As String 'E検索キー

Dim csresult As Range 'A検索結果
Dim chresult As Range 'B検索結果
Dim ckresult As Range 'C検索結果
Dim csyresult As Range 'D検索結果
Dim csyyresult As Range 'E検索結果

Application.ScreenUpdating = False '画面チラツキ防止

Workbooks.Open Filename:=copy & "\" & cn '転記先ファイルを開く
Set cWb = ActiveWorkbook
Set cWs = cWb.Worksheets("シート2")
Set cWs1 = cWb.Worksheets("シート3")
clastline = cWs.Cells(Rows.Count, "A").End(xlUp).Row '転記先ファイル入力シート最終行定義
c1lastline = cWs1.Cells(Rows.Count, "A").End(xlUp).Row

Set sWb = ThisWorkbook
Set sWs = sWb.Worksheets("シート1")
sslastline = sWs.Cells(Rows.Count, "C").End(xlUp).Row
shlastline = sWs.Cells(Rows.Count, "D").End(xlUp).Row
sklastline = sWs.Cells(Rows.Count, "E").End(xlUp).Row
ssylastline = sWs.Cells(Rows.Count, "F").End(xlUp).Row
ssyylastline = sWs.Cells(Rows.Count, "B").End(xlUp).Row

cWs.Range(Cells(2, 4), Cells(clastline, 7)).ClearContents '転記先セル値削除
'//Ａ
For a = 12 To sslastline '転記元の12行目から最終行まで1行ずつチェック
   sresult = Format(sWs.Cells(a, 3), "yyyy/m/d")
    If sresult = "" Then
    GoTo next1: '空白飛ばし
    End If
    
    Set csresult = cWb.Worksheets("シート2").Range(Cells(2, 1), Cells(clastline, 1)).Find(sresult, LookIn:=xlValues) '転記先との比較
        If Not csresult Is Nothing Then  '合致000
            If cWs.Cells(csresult.Row, 4).Value <> "" Then 'A列に値が入っていれば
            Cells(csresult.Row, 4).Value = Cells(csresult.Row, 4).Value + 1
            
            ElseIf Not csresult Is Nothing Then 'Ａ列に値が入っていなければ
            Cells(csresult.Row, 4).Value = 1
            
            End If
next1:
        
        End If
Next a
'//B
For b = 12 To shlastline '転記元の12行目から最終行まで1行ずつチェック
    hresult = Format(sWs.Cells(b, 4), "yyyy/m/d")
    If hresult = "" Then
    GoTo next2: '空白飛ばし
    End If
    
    Set chresult = cWb.Worksheets("シート2").Range(Cells(2, 1), Cells(clastline, 1)).Find(hresult, LookIn:=xlValues) '転記先との比較
        If Not chresult Is Nothing Then  '合致
            If cWs.Cells(chresult.Row, 5).Value <> "" Then 'B列に値が入っていれば
            Cells(chresult.Row, 5).Value = Cells(chresult.Row, 5).Value + 1
            
            ElseIf Not chresult Is Nothing Then 'Ｂ列に値が入っていなければ
            Cells(chresult.Row, 5).Value = 1
            
            End If
next2:
        
        End If
Next b
'//C
For c = 12 To sklastline '転記元の12行目から最終行まで1行ずつチェック
    kresult = Format(sWs.Cells(c, 5), "yyyy/m/d")
    If kresult = "" Then
    GoTo next3: '空白飛ばし
    End If
    
    Set ckresult = cWb.Worksheets("シート2").Range(Cells(2, 1), Cells(clastline, 1)).Find(kresult, LookIn:=xlValues) '転記先との比較
        If Not ckresult Is Nothing Then  '合致
            If cWs.Cells(ckresult.Row, 6).Value <> "" Then 'C列に値が入っていれば
            Cells(ckresult.Row, 6).Value = Cells(ckresult.Row, 6).Value + 1
            
            ElseIf Not ckresult Is Nothing Then 'Ｃ列に値が入っていなければ
            Cells(ckresult.Row, 6).Value = 1
            
            End If
next3:
        
        End If
Next c
'//D
For d = 12 To ssylastline '転記元の12行目から最終行まで1行ずつチェック
    syresult = Format(sWs.Cells(d, 6), "yyyy/m/d")
    If syresult = "" Then
    GoTo next4: '空白飛ばし
    End If
    
    Set csyresult = cWb.Worksheets("シート2").Range(Cells(2, 1), Cells(clastline, 1)).Find(syresult, LookIn:=xlValues) '転記先との比較
        If Not csyresult Is Nothing Then  '合致
            If cWs.Cells(csyresult.Row, 7).Value <> "" Then 'D列に値が入っていれば
            Cells(csyresult.Row, 7).Value = Cells(csyresult.Row, 7).Value + 1
            
            ElseIf Not csyresult Is Nothing Then 'Ｄ列に値が入っていなければ
            Cells(csyresult.Row, 7).Value = 1
            
            End If
next4:
        
        End If
Next d


'//E
cWb.Worksheets("シート3").Activate
cWs1.Range(Cells(2, 2), Cells(clastline, 2)).ClearContents
For e = 12 To ssyylastline '転記元の2行目から最終行まで1行ずつチェック
    syyresult = Format(sWs.Cells(e, 2), "yyyy年m月") 'yyyy年m月に変換
    If syyresult = "" Then
    GoTo next5: '空白飛ばし
    End If
    
    Set csyyresult = cWb.Worksheets("シート3").Range(Cells(2, 1), Cells(c1lastline, 1)).Find(syyresult, LookIn:=xlValues) '転記先との比較
        If Not csyyresult Is Nothing Then   '合致
            If cWs1.Cells(csyyresult.Row, 2).Value <> "" Then 'E列に値が入っていれば
            Cells(csyyresult.Row, 2).Value = Cells(csyyresult.Row, 2).Value + 1
            
            Else    '値が入っていなければ
            Cells(csyyresult.Row, 2).Value = 1
            
            End If
next5:
        
        End If
Next e

Application.DisplayAlerts = False
cWb.Worksheets("シート2").Activate '入力シートへ戻す
ActiveWorkbook.SaveAs Filename:=copy & "\" & "転記先.xlsx"  '保存
ActiveWorkbook.Close
Application.DisplayAlerts = True  'メッセージ表示※上書き保存
Application.ScreenUpdating = True '画面チラツキ防止
MsgBox "更新完了"

End Sub

Answer 1

既に回答が出てますし、Scripting.Dictionaryを使うという事であまり大差ないと思いますが回答します。

変数名とかは、質問者さんのものを踏襲できるところは踏襲して
それ以外は、てきとうにつけました。
初めの列についてのコードのみにしてあります。

おかしい所や不明なところあればご指摘ください。

Sub 照合転記()
Const copy As String= "C:\Users\xxx\Desktop\yy\00_VBA\照合転記2"
Const cn As String = "転記先.xlsx"

Dim sslastline As Integer '転記元A最終行
Dim shlastline As Integer '転記元B最終行
Dim sklastline As Integer '転記先C最終行
Dim ssylastline As Integer '転記元D最終行
Dim ssyylastline As Integer '転記元E最終行
Dim clastline As Integer '転記先日付最終行
Dim c1lastline As Integer '転記先2日付最終行

Dim sWb As Workbook '転記元ファイル変'
Dim sWs As Worksheet '転記元ファイル変数
Dim cWb As Workbook '転記先ファイル変数
Dim cWs As Worksheet '転記先シート変数
Dim cWs1 As Worksheet '転記先製作指示台数シート変数


Set sWb = ThisWorkbook
Set sWs = sWb.Worksheets("シート1")
sslastline = sWs.Cells(Rows.Count, "C").End(xlUp).Row
shlastline = sWs.Cells(Rows.Count, "D").End(xlUp).Row
sklastline = sWs.Cells(Rows.Count, "E").End(xlUp).Row
ssylastline = sWs.Cells(Rows.Count, "F").End(xlUp).Row
ssyylastline = sWs.Cells(Rows.Count, "B").End(xlUp).Row


Set cWb = Workbooks.Open(Filename:=copy & "\" & cn) '転記先ファイルを開く
Set cWs = cWb.Worksheets("シート2")
Set cWs1 = cWb.Worksheets("シート3")
clastline = cWs.Cells(Rows.Count, "A").End(xlUp).Row '転記先ファイル入力シート最終行定義
c1lastline = cWs1.Cells(Rows.Count, "A").End(xlUp).Row

Dim t_Value As Variant

Dim t_DicCount As Object
Dim i As Long

Application.ScreenUpdating = False

cWs.Range(cWs.Cells(2, 4), cWs.Cells(clastline, 7)).ClearContents
cWs1.Range(cWs1.Cells(2, 2), cWs1.Cells(c1lastline, 2)).ClearContents

' 転記元C列の集計
Set t_DicCount = CreateObject("Scripting.Dictionary")
For i = 12 To sslastline
    t_Value = sWs.Cells(i, 3)
    If t_DicCount.Exists(t_Value) Then
        t_DicCount.Item(t_Value) = t_DicCount.Item(t_Value) + 1
    Else
        t_DicCount.Add t_Value, 1
    End If
Next

' 転記元C列の集計結果出力
For i = 2 To clastline
    t_Value = cWs.Cells(i, 1)
    If t_DicCount.Exists(t_Value) Then
        cWs.Cells(i, 4) = t_DicCount.Item(t_Value)
    End If
Next

' 転記元B列の集計
Set t_DicCount = CreateObject("Scripting.Dictionary")
For i = 12 To ssyylastline
    t_Value = Format(sWs.Cells(i, 2), "yyyy年m月")
    If t_DicCount.Exists(t_Value) Then
        t_DicCount.Item(t_Value) = t_DicCount.Item(t_Value) + 1
    Else
        t_DicCount.Add t_Value, 1
    End If
Next

' 転記元B列の集計結果出力
For i = 2 To c1lastline
    t_Value = cWs1.Cells(i, 1).Text
    If t_DicCount.Exists(t_Value) Then
        cWs1.Cells(i, 2) = t_DicCount.Item(t_Value)
    End If
Next

Application.ScreenUpdating = True

End Sub

Comments

[tatsu99]

①シート1のD列の日付の出現回数をシート２のE列へ設定する機能
②シート1のE列の日付の出現回数をシート２のF列へ設定する機能
③シート1のF列の日付の出現回数をシート２のG列へ設定する機能
④転記先.xlsxをクローズする機能
上記の機能が実装されていませんが、意図的なものでしょうか？

[xail2222]

コメントありがとうございます。
集計して結果を貼り付ける部分が不明だと思ったのでその機能だけにしました。

他の部分は余り気にしていません。
わかりやすくしたつもりでしたが、Dictionaryの部分がまだ難しいかな

[xail2222]

と思っていましたが、今見直すと質問者さんのコード
ActiveWorkbook.SaveAs
となってますね。
余りよろしくないですね。

すぐ終わるので大した問題にはならないと思いますが。

[jabe]

対応していただきありがとうございます。
指摘もしていただきありがとうございます。ActiveWorkbook.SaveAsについてはtatsu99さんｺｰﾄﾞを見て”こうやるんだ”と理解する事が出来ました。
Dictionaryが理解出来ていない為、tatsu99さんのｺｰﾄﾞを理解し、その後xail2222さんのｺｰﾄﾞを理解したいと考えていますので、引き続きよろしくお願いします。

みなさん、Dictionaryをどのように理解し活用出来る様になったのか、知りたいです😢。

[xail2222]

私が一番始めにDictionaryを知った時の解釈は、配列のインデックスが整数だけではないバージョンと言うような解釈でした。
普通の配列ならA(1)=2という感じで値を入れたりするわけですが、DictionaryはA("あ")=2という感じでキーとなる"あ"に対して値2を対応させるものという感じになります。

この事はもう理解済みかも知れませんが、取り敢えず私の解釈はこんな感じです。
活用出来るようになるには、何でもそうですが使っていって覚えるしか無いのでは。
あとDictionaryのすごい所は、仕組みはさておきキーから値を参照する時間がとても早い事です。

私のコードの説明をしますと、
If t_DicCount.Exists(t_Value) Then①
t_DicCount.Item(t_Value) = t_DicCount.Item(t_Value) + 1②
Else
t_DicCount.Add t_Value, 1③
End if

①t_Valueが既にキーとして使用済みかチェック
②使用済みの場合、値を1加算
③使用済みで無い場合、1を登録

という流れです。

これを繰り返す事でt_Valueの内容毎の件数がカウントできます。
はじめの質問者さんのコードもfindして一番始めは1をセット、それ以降は1を加算という流れでしたので、似ているかと思います。

tatsu99さんのｺｰﾄﾞを理解出来れば、私のコードを理解するのは難しくないと思うので頑張って下さい。

[jabe]

返信ありがとうございます。
コード説明少し理解出来ました、トライしてみます。

やはり、大量データを扱うには必須スキルですね。
実践で頑張ってみようと思います。

Answer 2

①以下コードはdicT1.Item(key) でキー項目（Key）に対応する値を設定・取得だと思いますが、＝で処理しているのはどういう意味になるのでしょうか？
dicT1(key) = row2
dicT2(key) = 0
②以下コードで呼び出している()内はどういう意味になるのでしょうか？
Call set_dicT1(arrval, dicT1, sWs, "C", maxrowC, 1)

①について
dicT1(key) = row2は
dicT1.add key,row2
と同じ意味です。
但し、既に同じkeyが存在する場合、dicT1.add key,row2はエラーになります。（そこで止まります）
dicT1(key) = row2の場合はrow2が上書きされます。
例としてkeyの値が'20220131'でrow2の値が20とします。
(20行目に2022/1/31がある場合です）
dicT1(key) = row2とdicT1.add key,row2は同じ結果になります。
そのあと、もし、40行目に2022/1/31があった場合ですが（実際はないはずですが）
dicT1(key) = row2を実行するとdict(key)には40が設定されます。（40の値で上書きされます）
dicT1.add key,row2はエラーになります。

②について
Call set_dicT1(arrval, dicT1, sWs, "C", maxrowC, 1)は、

    Dim wrow As Long
    Dim key As String
    Dim row2 As Long
    For wrow = 12 To maxrowC
        key = Format(sWs.Cells(wrow, "C").Value, "yyyymmdd")
        If key <> "" Then
            If dicT1.Exists(key) = True Then
                row2 = dicT1(key)
                arrval(1, row2) = arrval(1, row2) + 1
            End If
        End If
    Next

と同じことです。これでC列の日付の回数をarrval(1,xxx)に格納できます。
ここで、"C",maxrowC,1の値を"D",maxrowD,2にしたものをそのあとに同じように作れば、
D列の日付の回数をarrval(2,xxx)に格納できます。
結局、にたような同じ処理を４回繰り返すのは、長くなるので、
１つのサブルーチンで処理しているわけです。
（異なる部分のみを引数で渡せば、その引数に応じた処理をサブルーチン側で行います）

Comments

[jabe]

回答ありがとうございます。
重複時に上書きされるという意味なんですね、勉強になりました。
私はｺｰﾄﾞが長くなる傾向があるので、ｻﾌﾞﾙｰﾁﾝも実践で使用し学んでいこうと思います。

Answer 3

スピード対策なので、Scripting.Dictionaryを使用しました。
シート２のA列2行目～最終行には、空欄がないこと及び日付の重複がないことが前提です。
シート３のA列2行目～最終行には、空欄がないこと及び年月の重複がないことが前提です。

Option Explicit
Public Sub 照合転記()
    Const copy As String = "C:\Users\xxx\Desktop\yy\00_VBA\照合転記2"
    Const cn As String = "転記先.xlsx"
    Dim sWb As Workbook     '転記元ファイル変'
    Dim sWs As Worksheet    '転記元ファイル変数
    Dim cWb As Workbook     '転記先ファイル変数
    Dim cWs As Worksheet    '転記先シート変数
    Dim cWs1 As Worksheet   '転記先製作指示台数シート変数
    Dim maxrowC As Long     '転記元C列最終行
    Dim maxrowD As Long     '転記元D列最終行
    Dim maxrowE As Long     '転記元E列最終行
    Dim maxrowF As Long     '転記元F列最終行
    Dim maxrowB As Long     '転記元B列最終行
    Dim maxrow2 As Long     '転記先シート2 A列最終行
    Dim maxrow3 As Long     '転記先シート3 A列最終行
    Dim row1 As Long        'シート1　行番号
    Dim row2 As Long        'シート2　行番号
    Dim row3 As Long        'シート3　行番号
    Dim ix As Long
    Dim key As String
    Dim keyv As Variant
    Dim arrval As Variant   '回数格納配列(ix,行番号)
    Dim dicT1 As Object     '連想配列　キー：yyyymmdd 値：シート1の行番号
    Dim dicT2 As Object     '連想配列　キー：yyyymm 値：回数
    Set dicT1 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Set dicT2 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Set sWb = ThisWorkbook
    Set sWs = sWb.Worksheets("シート1")
    maxrowC = sWs.Cells(Rows.Count, "C").End(xlUp).Row
    maxrowD = sWs.Cells(Rows.Count, "D").End(xlUp).Row
    maxrowE = sWs.Cells(Rows.Count, "E").End(xlUp).Row
    maxrowF = sWs.Cells(Rows.Count, "F").End(xlUp).Row
    maxrowB = sWs.Cells(Rows.Count, "B").End(xlUp).Row
    
    Application.ScreenUpdating = False    '画面チラツキ防止

    Set cWb = Workbooks.Open(copy & "\" & cn)    '転記先ファイルを開く
    Set cWs = cWb.Worksheets("シート2")
    Set cWs1 = cWb.Worksheets("シート3")
    maxrow2 = cWs.Cells(Rows.Count, "A").End(xlUp).Row    '転記先ファイル入力シート最終行定義
    maxrow3 = cWs1.Cells(Rows.Count, "A").End(xlUp).Row
    cWs.Range("D2:G" & maxrow2).ClearContents
    cWs1.Range("B2:B" & maxrow3).ClearContents
    ReDim arrval(4, maxrow2) As Long
    'シート2の日付と行番号を記憶
    For row2 = 2 To maxrow2
        key = Format(cWs.Cells(row2, "A").Value, "yyyymmdd")
        dicT1(key) = row2
    Next
    'シート3の日付を記憶
    For row3 = 2 To maxrow3
        key = Format(cWs1.Cells(row3, "A").Value, "yyyymm")
        dicT2(key) = 0
    Next
    'シート1 C,D,E,F列処理
    Call set_dicT1(arrval, dicT1, sWs, "C", maxrowC, 1)
    Call set_dicT1(arrval, dicT1, sWs, "D", maxrowD, 2)
    Call set_dicT1(arrval, dicT1, sWs, "E", maxrowE, 3)
    Call set_dicT1(arrval, dicT1, sWs, "F", maxrowF, 4)
    'シート2へ回数を設定
    For row2 = 2 To maxrow2
        For ix = 1 To 4
            If arrval(ix, row2) > 0 Then
                cWs.Cells(row2, 3 + ix).Value = arrval(ix, row2)
            End If
        Next
    Next
    'シート1 B列処理
    For row1 = 12 To maxrowB
        key = Format(sWs.Cells(row1, "B").Value, "yyyymm")
        If key <> "" Then
            If dicT2.exists(key) = True Then
                dicT2(key) = dicT2(key) + 1
            End If
        End If
    Next
    'シート3へ回数を設定
    row3 = 2
    For Each keyv In dicT2.keys
        If dicT2(keyv) > 0 Then
            cWs1.Cells(row3, "B").Value = dicT2(keyv)
        End If
        row3 = row3 + 1
    Next
    cWb.Save
    cWb.Close
    Application.ScreenUpdating = True    '画面チラツキ防止
    MsgBox "更新完了"
    
End Sub

Private Sub set_dicT1(ByRef arrval As Variant, ByVal dicT1 As Object, ByVal ws As Worksheet, ByVal col As String, ByVal maxrow As Long, ByVal ix As Long)
    Dim wrow As Long
    Dim key As String
    Dim row2 As Long
    For wrow = 12 To maxrow
        key = Format(ws.Cells(wrow, col).Value, "yyyymmdd")
        If key <> "" Then
            If dicT1.exists(key) = True Then
                row2 = dicT1(key)
                arrval(ix, row2) = arrval(ix, row2) + 1
            End If
        End If
    Next
End Sub

Comments

[jabe]

迅速な対応ありがとうございます。
実行したところ、凄く速く処理が完了し驚きました。

お手数かけますが、Dictionaryｵﾌﾞｼﾞｪｸﾄが難しく理解出来ていない為、以下内容を教えてください。
①以下コードはdicT1.Item(key) でキー項目（Key）に対応する値を設定・取得だと思いますが、＝で処理しているのはどういう意味になるのでしょうか？
dicT1(key) = row2
dicT2(key) = 0
②以下コードで呼び出している()内はどういう意味になるのでしょうか？
Call set_dicT1(arrval, dicT1, sWs, "C", maxrowC, 1)