今だけ人気マンガ100円レンタル特集♪

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を貼ることも可能です。

    「【ExcelVBA】※困ってます!※CO」の補足画像1
      補足日時:2020/02/01 02:42
  • つらい・・・

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

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

A 回答 (10件)

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



2つに分かれてしまっているから使えないとかでしたら
「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」マクロを呼び出してください。
この回答への補足あり
    • good
    • 0
この回答へのお礼

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

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

とりあえず「集計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
    • good
    • 0

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
    • good
    • 0

とりあえず「集計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
    • good
    • 0

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


① A~Lの合計(計算式)
② A~Lの合計(値)
③ その他(具体的に説明して下さい)
    • good
    • 0
この回答へのお礼

①です。

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

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


日付をキーにしてソートしてしまっても良いですか?
    • good
    • 0
この回答へのお礼

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

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

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


「M3」セルの数式バーに表示されている物をコピペして提示していただけますか?
    • good
    • 0
この回答へのお礼

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

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

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



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

もしかしたら「都道府県」「区分1」「区分2」が同一で同じ「年月」の行は無いのでD~L列の集計を行えば良いのでしょうか?
    • good
    • 0
この回答へのお礼

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

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

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

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

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



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


・・・余談・・・

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

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

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

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

お礼日時:2020/02/02 02:52
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


このカテゴリの人気Q&Aランキング