【Excel VBA】SUMIFを使わず高速で条件付き合計

2No(@2No45519933)です。
普段使用しているExcel。
手軽に計算ができるので、毎日使っているのですが、
大量のデータに対して内蔵されている関数を使うと処理が終わるまでしばらく待機。
最悪Excel自体が落ちちゃうなんてことがありました。
特に条件付きで合計値を出す、SUMIFがExcel内の処理の影響か、計算が終了まで恐ろしく時間がかかる…
今回はそんな条件付き合計をExcel関数SUMIFを使わず、Excel VBAで数秒まで短縮した方法。
参考
http://www4.synapse.ne.jp/yone/excel_exercise/exercise_vba_goukei.html
はじめに
作業で重複しているキーに対して、一度重複を削除。
その後、単一のキーに対して情報一覧からその合計を求めることに。
もらったファイルを覗いた所、30万行超え…
桁数間違えた?と思って桁数確認しちゃったよ…
とりあえず何も考えず、ExcelのSUMIF関数を使用したところ、処理終了まで5時間以上待機。
こんなの待っていられんと何も考えず、VBAでApplication.WorksheetFunction.SUMIFを使った所
何も変わらず5時間以上待機。
ダメじゃん…
ということで、WorksheetFunction.SUMIFを使わずに同じ結果になるようにVBAで作成してみました。
やりたいこと
重複しているキーの重複削除
一覧からキーを検索して、そこに対応している数量を加算
構成はこんな感じをイメージ
データ(元データシート)
検索キー | 値 |
A | 10 |
B | 5 |
C | 9 |
A | 1 |
C | 1 |
計算結果(合計結果シート)
検索キー | 合計値 |
A | 11 |
B | 5 |
C | 10 |
条件を指定して数値を合計するコード
元データが上書きされて確認が出来ないことを防ぐ為、
結果は別シートに出力されるようにしています。
※自分の作成したいように書き換えてください
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
Option Explicit Sub sumifVba() Debug.Print Time & "-Start" Dim startTime As Double Dim endTime As Double Dim processTime As Double startTime = Timer '初期設定 '処理速度を早くするために、機能を一旦変更 Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.EnableEvents = False '================================================== 'メイン処理 '================================================== Dim wsList As Worksheet Dim wsSum As Worksheet Set wsList = Worksheets("元データ") Set wsSum = Worksheets("合計結果") '検索キーの重複を消してコピー Dim itemCount As Long itemCount = getLastRow(wsList) wsList.Range("A1:A" & itemCount).AdvancedFilter _ Action:=xlFilterCopy, CopyToRange:=wsSum.Range("A1"), Unique:=True wsSum.Cells(1, 1) = "Key" wsSum.Cells(1, 2) = "Result" Dim searchArray As Variant Dim refArray As Variant Dim keyVal As String Dim itemVal As Long Dim maxRowList As Long Dim maxRowSum As Long Dim i As Long Dim n As Long Dim myStr As String Dim myDic As Object maxRowSum = getLastRow(wsSum) wsSum.Activate searchArray = Range(Cells(2, 1), Cells(maxRowSum, 2)) wsStock.Activate maxRowStock = getLastRow(wsStock) refArray = Range(Cells(2, 1), Cells(maxRowStock, 2)) Set myDic = CreateObject("Scripting.Dictionary") For n = 1 To UBound(refArray) keyVal = refArray(n, 1) itemVal = refArray(n, 2) If Not myDic.Exists(keyVal) Then myDic.Add keyVal, itemVal Else myDic(keyVal) = myDic(keyVal) + itemVal End If Next n For n = 1 To UBound(searchArray) keyVal = searchArray(n, 1) searchArray(n, 2) = myDic(keyVal) Next n wsSum.Activate Range(Cells(2, 1), Cells(maxRowSum, 2)) = searchArray Set myDic = Nothing '設定をもとに戻す Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.EnableEvents = True End Sub '指定したシートの最終行数を取得する '第2引数の省略可能。省略した場合1列目を参照 Public Function getLastRow(sheetName As Worksheet, Optional checkCol As Long = 1) As Long getLastRow = sheetName.Cell(sheetName.Rows.Count, checkCol).End(xlUp).Row End Function |
同じ行数のデータに対してこのマクロを使った所、私のPCでは大体10秒前後で完了…
5時間が10秒まで短縮することが出来た!やったぜ。
これで待機中にTwitterのTLを覗けなくなりました。
うーん残念?w
また効率化できそうなことがあれば追記していきたいと思います。
みなさま良いExcel VBAライフを!
それでは!
ディスカッション
コメント一覧
まだ、コメントがありません