【ExcelVBA】※困ってます！※COUNTIFS関数と同等の処理をマクロでできますか？

Bookの中にシートは以下の3つあります。
リスト・・・1万件あります
集計1
集計2

集計1,2ともに、リストからCOUNTIFS関数で個数を集計するのですが、
1万行あるせいか、10分以上再計算が走り使い物になりません。
マクロで何とかならないでしょうか？

以下、具体的な処理内容です。画面キャプチャーも添付しますが、読めるかどうか。
--------------------
【集計1では】
「リスト」シートから
都道府県、区分1、区分2が一致する、「2020年4月」の数を集計　（2021年6月まで）

関数だとD3には以下の数式が入ってます。R列まで数式貼り付けています。
=COUNTIFS(リスト!$A:$A,$A3,リスト!$B:$B,$B3,リスト!$C:$C,$C3,リスト!$M:$M,D$2)
--------------------
【集計2では】
「リスト」シートから
都道府県、区分1、区分2が一致し、Aに値が入っている個数を集計
（同様にA～Iまで）

関数だとD2に次の数式が入っています。L列まで数式を貼り付けています。
=COUNTIFS(リスト!$A:$A,$A2,リスト!$B:$B,$B2,リスト!$C:$C,$C2,リスト!D:D,"?*")
--------------------
多少の拡張は自力でやりたいと思いますが、ベースを教えていただけると
大変助かります。

質問者からの補足コメント

• 画面キャプチャーです。
  掲載時の縮小の仕組みが分からないので、
  ちゃんと判別するためのサイズなど教えていただければ再添付します。
  画像をアップしてURLを貼ることも可能です。

  
    補足日時：2020/02/01 02:42

• 

  遅くて大変申し訳ありません。
  月曜にテストできればと思ってます。

  No.10の回答に寄せられた補足コメントです。 補足日時：2020/02/08 17:26

No.1 回答者： akudaikan55 回答日時： 2020/02/01 03:45

下記の方法で行けるかも

方法１
https://officedic.com/excel-vba-countifs-dic/
方法２
https://detail.chiebukuro.yahoo.co.jp/qa/questio …

No.2 回答者： 銀鱗 回答日時： 2020/02/01 07:43

ああ、それ数式の作り方が悪いだけの話です。

各列のすべての行を検索しているよね。そんなじゃ時間がかかるのは当たり前です。
行数を指定しましょう。それだけで改善しますよ。
1,048,576行まで検索する必要があるならそのままでも良いのですが、たかだか10,000行でしょ。
数えるのが面倒なら20,000行まで指定しておけば良いと思います。
面倒でも数式を修正することを強く勧めます。


・・・余談・・・

ここ「教えて!goo」に貼り付ける画像は、500×500ピクセルに収まるように縮小されます。
500×500ピクセル以下の画像はオリジナルのサイズで表示されます。

この回答へのお礼

行数指定だけでそんなに変わるんですね？驚きました。
今まで無駄な負荷を与えてました。行数が多くなくて気づかなかっただけです。

画像添付の仕様も分かりました。

ありがとうございました。

お礼日時：2020/02/02 02:52

No.3 回答者： GooUserラック 回答日時： 2020/02/01 15:22

図が良く見えないので、こちらの勘違いかもしれませんが「リスト」シートのＤ～Ｌ列は数字ではなく「有」「無」の２文字が有るように見えます（違っていたらご指摘ください）

集計は次のどれのように行うのでしょうか？
①「有」「無」などの文字に関係なく、文字が有れば「1」なければ「0」として扱う
②「有」の文字が有れば「1」空白を含めその他は「0」として扱う
③ その他（具体的に詳しく説明して下さい）

もしかしたら「都道府県」「区分1」「区分2」が同一で同じ「年月」の行は無いのでＤ～Ｌ列の集計を行えば良いのでしょうか？

この回答へのお礼

画像が小さくて失礼いたしました。
①です。数字文字関係なく空白以外です。

D～L列の項目名は
A～Iです。

集計2のA(D列)はCSVシートの項目名Aの値が入っている数を集計しています。
同じくIまで集計します。

お礼日時：2020/02/02 02:50

No.4 回答者： GooUserラック 回答日時： 2020/02/02 03:36

「リスト」シートのＭ列のデータはどんなものでしょうか？

「M3」セルの数式バーに表示されている物をコピペして提示していただけますか？

この回答へのお礼

確認が遅くなり申し訳ありません。
お察しのことと思いますが、2020/6/1です。

お礼日時：2020/02/02 23:56

No.5 回答者： GooUserラック 回答日時： 2020/02/02 04:05

もしも「M3」セルの数式バーに表示されているものが「yyyy/m/d」のような「日」のデータを含んでいた場合、全て月の初日「yyyy/m/1」に変換してしまっても良いですか？（範囲指定で比較すると時間がかかるので）

日付をキーにしてソートしてしまっても良いですか？

この回答へのお礼

先に追加で回答いただいていて、こちらの確認が遅くなり申し訳ありません。
ソートはなるべく行いたくありません。

お礼日時：2020/02/02 23:57

No.6 回答者： GooUserラック 回答日時： 2020/02/02 06:42

「集計2」シートのM列は何でしょうか？

① A～Lの合計（計算式）
② A～Lの合計（値）
③ その他（具体的に説明して下さい）

この回答へのお礼

①です。

お礼日時：2020/02/02 23:57

No.7 回答者： GooUserラック 回答日時： 2020/02/02 08:51

とりあえず「集計1」を作成してみました。

こんな感じでよろしいでしょうか？

Sub 集計1作成()
Dim 終行 As Long
Dim 行 As Long
Dim 列 As Long
Dim 計 As Long
Dim 地区キー As String
Dim 地区辞書 As Object
Dim 年月辞書 As Object
　Set 地区辞書 = CreateObject("Scripting.Dictionary")
　Set 年月辞書 = CreateObject("Scripting.Dictionary")
　Sheets("集計1").Select
　Cells.Delete Shift:=xlUp
　Sheets("リスト").Select
　Range(Cells(2, 1), Cells(Cells(Rows.Count, 13).End(xlUp).Row, 13)).Copy
　Sheets("集計1").Select
　Range("A1").Select
　ActiveSheet.Paste
　Selection.EntireColumn.AutoFit
　Selection.Sort Key1:=Range("M2"), Order1:=xlAscending, Header:=xlYes
　終行 = Cells(Rows.Count, 13).End(xlUp).Row
　Application.ScreenUpdating = False
　For 行 = 2 To 終行
　　Cells(行, 13).Value = Cells(行, 13).Text
　　計 = 0
　　For 列 = 4 To 12
　　　If Trim(Cells(行, 列).Value) <> "" Then 計 = 計 + 1
　　Next
　　If 年月辞書.Exists(Cells(行, 13).Value) Then
　　　列 = 年月辞書.Item(Cells(行, 13).Value)
　　Else
　　　列 = Cells(1, Columns.Count).End(xlToLeft).Column + 1
　　　Cells(1, 列).Value = Cells(行, 13).Value
　　　Cells(1, 列).NumberFormatLocal = "yyyy""年""m""月"""
　　　年月辞書.Add Cells(行, 13).Value, 列
　　End If
　　地区キー = Cells(行, 1).Value & vbTab & Cells(行, 2).Value & vbTab & Cells(行, 3).Value
　　If 地区辞書.Exists(地区キー) Then
　　　Range(Cells(行, 1), Cells(行, 3)).ClearContents
　　Else
　　　地区辞書.Add 地区キー, 行
　　End If
　　Cells(地区辞書.Item(地区キー), 列).Value = Cells(地区辞書.Item(地区キー), 列).Value + 計
　Next
　Columns("D:M").Delete Shift:=xlToLeft
　Set 地区辞書 = Nothing
　Set 年月辞書 = Nothing
　Cells.Sort _
　　Key1:=Range("A2"), Order1:=xlAscending, _
　　Key2:=Range("B2"), Order2:=xlAscending, _
　　Key3:=Range("C2"), Order3:=xlAscending, _
　　Header:=xlYes
　Application.ScreenUpdating = True
　Range("D2").Select
　ActiveWindow.FreezePanes = True
　行 = Cells(Rows.Count, 13).End(xlUp).Row + 1
　Rows(行 & ":" & Rows.Count).Delete Shift:=xlUp
　行 = ActiveSheet.UsedRange.Row
End Sub

No.8 回答者： GooUserラック 回答日時： 2020/02/02 10:16

No.7 の修正版です。

極力元の順番を変えないバージョンです。（処理時間が数秒伸びるかも？）

Sub 集計1作成()
Dim 終行 As Long
Dim 行 As Long
Dim 列 As Long
Dim 計 As Long
Dim 地区キー As String
Dim 地区辞書 As Object
Dim 年月辞書 As Object
　Set 地区辞書 = CreateObject("Scripting.Dictionary")
　Set 年月辞書 = CreateObject("Scripting.Dictionary")
　Sheets("集計1").Select
　Cells.Delete Shift:=xlUp
　Sheets("リスト").Select
　Range(Cells(2, 1), Cells(Cells(Rows.Count, 13).End(xlUp).Row, 13)).Copy
　Sheets("集計1").Select
　Range("A1").Select
　ActiveSheet.Paste
　Selection.EntireColumn.AutoFit
　終行 = Cells(Rows.Count, 13).End(xlUp).Row
　Application.ScreenUpdating = False
　For 行 = 2 To 終行
　　Cells(行, 13).Value = Cells(行, 13).Text
　　計 = 0
　　For 列 = 4 To 12
　　　If Trim(Cells(行, 列).Value) <> "" Then 計 = 計 + 1
　　Next
　　If 年月辞書.Exists(Cells(行, 13).Value) Then
　　　列 = 年月辞書.Item(Cells(行, 13).Value)
　　Else
　　　列 = Cells(1, Columns.Count).End(xlToLeft).Column + 1
　　　Cells(1, 列).Value = Cells(行, 13).Value
　　　Cells(1, 列).NumberFormatLocal = "yyyy""年""m""月"""
　　　年月辞書.Add Cells(行, 13).Value, 列
　　End If
　　地区キー = Cells(行, 1).Value & vbTab & Cells(行, 2).Value & vbTab & Cells(行, 3).Value
　　If 地区辞書.Exists(地区キー) Then
　　　Range(Cells(行, 1), Cells(行, 13)).ClearContents
　　Else
　　　地区辞書.Add 地区キー, 行
　　　Cells(行, 13).Value = 行
　　End If
　　Cells(地区辞書.Item(地区キー), 列).Value = Cells(地区辞書.Item(地区キー), 列).Value + 計
　Next
　Set 地区辞書 = Nothing
　Set 年月辞書 = Nothing
　Columns("N:" & StrReverse(Mid(StrReverse(Cells(1, Columns.Count).Address(False, False)), 2))).Sort _
　　Key1:=Range("N1"), _
　　Order1:=xlAscending, _
　　Header:=xlNo, _
　　Orientation:=xlLeftToRight
　Cells.Sort _
　　Key1:=Range("M2"), Order1:=xlAscending, _
　　Header:=xlYes, _
　　Orientation:=xlTopToBottom
　Columns("D:M").Delete Shift:=xlToLeft
　Application.ScreenUpdating = True
　Range("D2").Select
　ActiveWindow.FreezePanes = True
　行 = Cells(Rows.Count, 13).End(xlUp).Row + 1
　Rows(行 & ":" & Rows.Count).Delete Shift:=xlUp
　行 = ActiveSheet.UsedRange.Row
End Sub

No.9 回答者： GooUserラック 回答日時： 2020/02/03 02:12

とりあえず「集計2」を作成してみました。

こんな感じでよろしいでしょうか？

Sub 集計2作成()

Dim 行 As Long
Dim 列 As Long
Dim 終行 As Long
Dim 地区キー As String
Dim 地区辞書 As Object
Dim データ As Variant

　Set 地区辞書 = CreateObject("Scripting.Dictionary")
　Sheets("集計2").Columns("A:M").ClearContents
　Sheets("リスト").Select
　Range(Cells(2, 1), Cells(Cells(Rows.Count, 13).End(xlUp).Row, 13)).Copy
　Sheets("集計2").Select
　Range("A1").Select
　ActiveSheet.Paste
　Columns("M:M").NumberFormatLocal = "G/標準"
　Range("M1").Value = "合計" ' 見えないので適当に直してください
　終行 = Cells(Rows.Count, 13).End(xlUp).Row
　データ = Range(Cells(1, 1), Cells(終行, 13))
　For 行 = 2 To 終行
　　For 列 = 4 To 12
　　　If Trim(データ(行, 列)) = "" Then
　　　　データ(行, 列) = 0
　　　Else
　　　　データ(行, 列) = 1
　　　End If
　　Next
　Next
　For 行 = 2 To 終行
　　地区キー = データ(行, 1) & vbTab & データ(行, 2) & vbTab & データ(行, 3)
　　If 地区辞書.Exists(地区キー) Then
　　　データ(行, 13) = ""
　　　For 列 = 4 To 12
　　　　データ(地区辞書.Item(地区キー), 列) = データ(地区辞書.Item(地区キー), 列) + データ(行, 列)
　　　Next
　　Else
　　　地区辞書.Add 地区キー, 行
　　　データ(行, 13) = 行
　　End If
　Next
　Range(Cells(1, 1), Cells(終行, 13)) = データ
　Columns("A:M").Sort _
　　Key1:=Range("M2"), Order1:=xlAscending, _
　　Header:=xlYes
　行 = Cells(Rows.Count, 13).End(xlUp).Row + 1
　Rows(行 & ":" & Rows.Count).Delete Shift:=xlUp
　行 = ActiveSheet.UsedRange.Row
　Range("M2").FormulaR1C1 = "=SUM(RC[-9]:RC[-1])"
　Range("M2").Copy Range(Cells(3, 13), Cells(Cells(Rows.Count, 13).End(xlUp).Row, 13))
　Columns("A:M").EntireColumn.AutoFit
　Range("A2").Select

End Sub

No.10 ベストアンサー 回答者： GooUserラック 回答日時： 2020/02/05 00:37

なかなか終了しませんね？

２つに分かれてしまっているから使えないとかでしたら
「Sub 集計1作成()」～「End Sub」を「Sub 集計1作成(Optional ダミー As Byte)」～「End Sub」
「Sub 集計2作成()」～「End Sub」を「Sub 集計2作成(Optional ダミー As Byte)」～「End Sub」
にしておいて以下を作成して
----------------------------
Sub Sample()
　Call 集計1作成
　Call 集計2作成
End Sub
----------------------------
「Sample」マクロを呼び出してください。

この回答へのお礼

すみません。後から問題が山積みになって確認できてないだけです。急ぎます。

お礼日時：2020/02/05 14:57