【再質問】SUMIF関数と同じ集計をVBAで行いたい

質問

恐縮なのですが、今一度質問させてください。
今はSUMIF関数で複数シートデータの集計をしていますが、
データ数が膨大なため処理に多大な時間が掛かっています。
VBAで同じ様な処理がしたく、ご教授の程よろしくお願いします。
Sheetは1～12まであり、同じレイアウトです。
行数は、Sheetごとに異なります。
集計結果Sheetに、品名ごとの月集計をしたい。

Sheet1
　　　A　　　　B　　　　C　　　　D
1 月日　　品名　　 収入 支出
2　5/10　 りんご　 30000　 20000
3　5/15　 さかな　 20000　 30000　
4　5/20　 きのこ　 50000　 20000
5　5/25　 さかな　 30000　 10000
6　5/30　 おかし　 15000　 10000
7　5/30　 おかし　 20000　 20000
5　5/10　 りんご　 40000　 20000

Sheet2
　　　A　　　　B　　　　C　　　　D
1 月日　　品名　　 収入 支出
2　6/13　 きのこ　 10000　 30000
3　6/25　 さかな　 20000　 20000
4　6/30　 おかし　 55000　 30000
5　6/10　 りんご　 20000　 10000
6　6/15　 さかな　 10000　 10000

集計結果Sheet
　　　A　　　　B　　　　C　　　　D
1 品名　　　4月　　　5月　　　6月
2　きのこ　
3　さかな　
4　おかし　
5　りんご　

例）きのこ　4月の収入-支出を、B2セルに入力したい。
シートは4月・5月と、月別に分かれています。

回答No.6

okormazd · ベストアンサー

ANo.3
です。

集計シートに品名が、あらかじめ入力してあるようにつくってます。
集計シートのA2から品名を入力しておいてください。

で、いいはずですが。

お礼

出来ました！
丁重なご回答、ありがとうございました。

回答No.8

okormazd

ANo.3
これでだめなら、集計シートの品名と各月の品名が一致していない可能性があります。品名の前後の空白などをなくしてください。

回答No.7

noname#140971

仮に集計結果シートの品目が昇順に並んでりゃー・・・。

Private Sub CommandButton2_Click()

のコードを多少改造すれば、高速化するかも知れません。

１、集計結果シートの品目を配列に取り込む。

集計結果(XXX, X)

２、strDatas() を基に集計結果(XXX, X)を加算・更新する。

バイナリーサーチを使う。

３、集計結果(XXX, X)に基づき集計結果シートを更新する。

メモリオーバーで暴走するようであれば、配列読み込みから順次読み込みに手法を変える。

[イミディエイト]
? FileRead("C:\temp\sheet1.csv")
月日,品名,収入, 支出
? FileRead("C:\temp\sheet1.csv")
5月10日,りんご,30000,20000
? FileRead("C:\temp\sheet1.csv")
5月15日,さかな,20000,30000

ヒントばかりじゃなんですから・・・。

以下の関数があれば、単純なVBAコードで上記アイデアは実現できる筈です。
バイナリーサーチは、どこかに解説されていると思います。

Public Function CutStr(ByVal Text As String, _
　　　　　　　　　　　 ByVal Separator As String, _
　　　　　　　　　　　 ByVal N As Integer) As String
　　Dim strDatas() As String

　　strDatas = Split("" & Separator & Text, Separator, , 0)
　　CutStr = strDatas(N * Abs((N <= UBound(strDatas))))
End Function

Public Function FileReadArray(ByVal FileName As String) As String()
On Error GoTo Err_FileReadArray
　　Dim fso As Object
　　Dim strTexts() As String

　　Set fso = CreateObject("Scripting.FIleSystemObject")
　　strTexts() = Split(fso.OpenTextFile(FileName).ReadAll, vbCrLf)
Exit_FileReadArray:
　　FileReadArray = strTexts()
　　Exit Function
Err_FileReadArray:
　　MsgBox Err.Description & "(FileReadArray)", vbExclamation, " 関数エラーメッセージ"
　　strTexts() = Split("")
　　Resume Exit_FileReadArray
End Function

Public Function FileRead(ByVal FileName As String, Optional isStop As Boolean = False) As String
On Error GoTo Err_FileRead
　　Static isOpen As Boolean
　　Static fso As Object
　　Static fil　　As File
　　Static txs　　As TextStream

　　If Not isOpen Then
　　　　isOpen = True
　　　　Set fso = CreateObject("Scripting.FIleSystemObject")
　　　　Set fil = fso.GetFile(FileName)
　　　　Set txs = fil.OpenAsTextStream(ForReading, TristateUseDefault)
　　End If
　　FileRead = txs.ReadLine
Exit_FileRead:
　　If Len(FileRead) = 0 Or isStop Then
　　　　isOpen = False
　　　　Set txs = Nothing
　　　　Set fil = Nothing
　　　　Set fso = Nothing
　　End If
　　Exit Function
Err_FileRead:
　　Resume Exit_FileRead
End Function

Public Function DeleteFile(ByVal FileName As String) As Boolean
On Error GoTo Err_DeleteFile
　　Dim isOK　　As Boolean
　　Dim fso　　 As FileSystemObject

　　Set fso = New FileSystemObject
　　fso.DeleteFile FileName
　　isOK = True
Exit_DeleteFile:
　　DeleteFile = isOK
　　Exit Function
Err_DeleteFile:
　　Resume Exit_DeleteFile
End Function

お礼

ご回答、ありがとうございました。
ただ初心者の私には、余りにも難し過ぎて。
頑張って勉強し、理解できるようにします。

回答No.5

noname#140971

補足: 示したコードはテストしても無駄です。

CutStr関数、FileReadArray関数が存在しないと思います。
また、１～１０は、そりゃーA4数ページのコードになるでしょう。
ここでの質疑応答レベルをこえています。
あくまでも、ヒントとして読んで下さい。

回答No.4

noname#140971

[イミディエイトウインドウ]
月日,品名,収入, 支出
5月10日,りんご,30000,20000
5月15日,さかな,20000,30000

月日,品名,収入, 支出
5月11日,りんご,30000,20000
5月16日,おかし,20000,30000

月日,品名,収入, 支出
5月12日,りんご,30000,20000
5月17日,おかし,20000,30000

このように３つのシートを一旦 CSV で保存してから再読込してイミディエイトウインドウに表示してみました。

Const conSHEETNAMES = "Seet1.CSV/Seet2.CSV/Seet3.CSV"

Private Sub CommandButton1_Click()
　　Dim I As Integer

　　For I = 1 To 3
　　　　Sheets(I).Select
　　　　ActiveWorkbook.SaveAs FileName:="C:\Temp\" & CutStr(conSHEETNAMES, "/", I), FileFormat:=xlCSV, CreateBackup:=False
　　Next I
End Sub

Private Sub CommandButton2_Click()
　　Dim I　　　　　As Integer
　　Dim J　　　　　As Integer
　　Dim N　　　　　As Integer
　　Dim strDatas() As String

　　For I = 1 To 3
　　　　strDatas() = FileReadArray("C:\Temp\" & CutStr(conSHEETNAMES, "/", I))
　　　　N = UBound(strDatas())
　　　　For J = 0 To N
　　　　　　Debug.Print strDatas(J)
　　　　Next J
　　Next I
End Sub

問題は、 CommandButton2_Click()の部分を別に書いたが無難だということです。
このように、シートデータを配列変数に取り込めば、いかようにも集計できるかと思います。
集計アプリケーションとは、この部分を指しています。
エクセルのセルの一つひとつにアクセスすりゃ時間も掛かるでしょう。
だが、一気に配列に取り込めば、もしかしたら高速化できるかも（？）しれません。

もちろん、SaveAs なんて急遽ヘルプで調べて書いた付け刃。
もっと、良い方法があるかも知れません。
一応、テストでは成功しています。

回答No.3

okormazd

このブックのsheet(1)（先頭のシート名）を「集計」とする。
以下sheet(2)からsheet(13)までが４月～３月までのデータとします。

Sub test()

Dim wb As Object, syk As Object

Set wb = Workbooks(ThisWorkbook.Name)
Set syk = wb.Sheets("集計")

With syk

For sh = 2 To 13

r = 2
c = 1

hinmei0 = .Cells(r, c)
While hinmei0 <> ""

With wb.Sheets(sh)

rs = 2
cs = 2
syunyu = 0
sisyutu = 0

hinmei = .Cells(rs, cs)
While hinmei <> ""

If hinmei = hinmei0 Then
syunyu = syunyu + .Cells(rs, cs + 1)
sisyutu = sisyutu + .Cells(rs, cs + 2)
End If

rs = rs + 1
hinmei = .Cells(rs, cs)

Wend

End With

.Cells(r, c + sh - 1) = syunyu - sisyutu

r = r + 1
hinmei0 = .Cells(r, c)

Wend

Next

End With

End Sub

データ量が多ければそれだけ時間はかかります。

補足

すみません。
作動しエラーも出ませんが、何も入力されません。
集計シートを先頭にし、他シート名は4月～3月で宜しいのでしょうか。
また、各月シートの1行目は
　　　A　　　　B　　　　C　　　　D
1 月日　　品名　　 収入 支出

集計シートの1行目は
　　　A　　　　B　　　　C　　　　D
1 品名　　　4月　　　5月　　　6月

で、宜しいのでしょうか。

回答No.2

noname#140971

エクセルは現実には一度も操作したことのない門外漢ですので相当に外しているかもですが・・・。

１、一旦、ブックをCSV形式で保存する。
２、集計アプリケーションを起動する。
３、集計アプリケーションでは、まず、シート１を配列に呼び込む。
４、集計アプリケーションでは、次に、[品名]+[月日]でソートする。
５、集計アプリケーションでは、更に、集計する。
６、集計アプリケーションでは、集計結果をどこぞに記録する。
７、集計アプリケーションは、２～５を繰り返す。
８、集計アプリケーションは、CSV形式のファイルを削除する。
９、集計アプリケーションは、最終集計結果をCSV等で出力する。
１０、エクセルは最終集計結果が作成されたら集計シートに呼び込む。

このやり方ですと、難しいコードを書かなくても済みます。
このやり方ですと、当該エクセル外で高速計算されるかも（？）しれません。

＜４、[品名]+[月日]でソートする＞の留意点。

・以前、クイックソートを使ってソートしたらエクセルは暴走しました。
・集計アプリケーションをエクセルで作成する場合は要注意かと思います。

補足

すみません、２、集計アプリケーションを起動する。
↑どのソフトを起動したら良いのでしょうか？

回答No.1

suz83238

ためしにやってみて下さい。
表示に時間がかかるようなら、何をやってもダメと思います。
パソコンを速いものにしましょう。

Sub xxx()
s = 0
For i = 2 To Worksheets("sheet1").Cells.SpecialCells(xlLastCell).Row
If Cells(i, 2) = "りんご" Then s = s + Cells(i, 3).Value - Cells(i, 4).Value
Next i
MsgBox s
End Sub