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

2019年11月13日

2No(@2No45519933)です。

普段使用しているExcel。
手軽に計算ができるので、毎日使っているのですが、
大量のデータに対して内蔵されている関数を使うと処理が終わるまでしばらく待機。
最悪Excel自体が落ちちゃうなんてことがありました。

特に条件付きで合計値を出す、SUMIFがExcel内の処理の影響か、計算が終了まで恐ろしく時間がかかる…

今回はそんな条件付き合計をExcel関数SUMIFを使わず、Excel VBAで数秒まで短縮した方法。
参考
http://www4.synapse.ne.jp/yone/excel_exercise/exercise_vba_goukei.html

1. はじめに
2. やりたいこと
3. 条件を指定して数値を合計するコード

はじめに

作業で重複しているキーに対して、一度重複を削除。
その後、単一のキーに対して情報一覧からその合計を求めることに。
もらったファイルを覗いた所、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

条件を指定して数値を合計するコード

元データが上書きされて確認が出来ないことを防ぐ為、
結果は別シートに出力されるようにしています。
※自分の作成したいように書き換えてください

Option Explicit

Sub sumifVba()
    Debug.Print Time &amp; "-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" &amp; 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

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を覗けなくなりました。

うーん残念？ｗ

また効率化できそうなことがあれば追記していきたいと思います。

みなさま良いExcel VBAライフを！

それでは！

Excel, VBAExcel, VBA

Posted by 2nolibrary

【Excelショートカット】もう一段階作業を早くするショートカット集

ディズニーツムツムのキングダムハーツイベントが一旦終わりましたね。

コメント一覧

まだ、コメントがありません

コメントをどうぞコメントをキャンセル

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください。