フラグを立てるvbaを教えてください。

画像にある符号がマイナスの行で同じ拠点、同じ日付、同じ金額、同じ商品コードを探して、
符号がプラスの行にフラグをたてて、相殺できるようにしたいです。
(判定1、判定2)の状態にしたいです。

VBAがあまり詳しくない初心者です。
10万桁の行があるファイルなので、できる限り早く処理できるとうれしいです。

御知恵をお貸しください。

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

• 伝票番号は変わることもありますので、同じでなくてもいいです。

  No.1の回答に寄せられた補足コメントです。 補足日時：2017/02/08 18:43

• すみません。検証したのは10000桁でした。
  当方の環境で10万桁で検証しますと、30分程
  かかりました。

  No.3の回答に寄せられた補足コメントです。 補足日時：2017/02/09 12:41

No.5 ベストアンサー 回答者： tatsu99 回答日時： 2017/02/09 12:53

No2です。

シート名に対する回答がないので、現在表示されているシートに対して操作を行います。
このマクロと無関係のシートを表示した状態で、このマクロを実行するとそのシートが破壊されますので
注意ください。
こちらの環境では、約10万件で８秒で終わっています。
以下のマクロを標準モジュールへ登録してください。
------------------------------------------------------------
Option Explicit
Public Sub 相殺()
Const delm As String = "|"
Dim maxrow As Long
Dim row As Long
Dim dicM1 As Object '連想配列 マイナス側（キー＝日付＋金額＋商品コード）値＝最大件数
Dim dicM2 As Object '連想配列 マイナス側（キー＝日付＋金額＋商品コード＋連番）値＝行番号
Dim dicP As Object '連想配列 プラス側（キー＝日付＋金額＋商品コード）値＝処理件数
Dim key1 As String
Dim key2 As String
Dim t1 As Variant
Dim t2 As Variant
t1 = Time
Set dicM1 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicM2 = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicP = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Application.ScreenUpdating = False
maxrow = Cells(Rows.Count, 1).End(xlUp).row '最大行取得
Range("J2:J" & maxrow).Value = ""
Range("K2:K" & maxrow).Value = ""
'マイナス側のデータを集計
For row = 2 To maxrow
'マイナス側なら連想配列に登録
If Cells(row, "H").Value = 1 Then
key1 = Cells(row, "C").Value & delm & Cells(row, "D").Value & delm & Cells(row, "E").Value
If dicM1.exists(key1) = True Then
dicM1(key1) = dicM1(key1) + 1
Else
dicM1(key1) = 1
End If
key2 = key1 & delm & dicM1(key1)
dicM2(key2) = row
End If
Next
'プラス側のデータを処理
For row = 2 To maxrow
'プラス側なら処理
If Cells(row, "H").Value = 0 Then
key1 = Cells(row, "C").Value & delm & Cells(row, "D").Value & delm & Cells(row, "E").Value
If dicM1.exists(key1) = True Then
If dicP.exists(key1) = True Then
dicP(key1) = dicP(key1) + 1
Else
dicP(key1) = 1
End If
'マイナス側の最大件数以内なら相殺フラグをON
If dicM1(key1) >= dicP(key1) Then
Cells(row, "J").Value = 1 'プラス側相殺
key2 = key1 & delm & dicP(key1)
Cells(dicM2(key2), "K").Value = "1" 'マイナス側相殺
End If
End If
End If
Next
Application.ScreenUpdating = True
t2 = Time
MsgBox ("終了しました Time=" & Minute(t2 - t1) & "分" & Second(t2 - t1) & "秒")
End Sub
---------------------------------------------------

この回答へのお礼

申しわけございません。
同じ回答者さんだと思ってスルーしていました。

ご回答ありがとうございます。

教えていただいたコードでテストしまして
うまくいきました。時間も早かったです。

お礼日時：2017/02/09 14:19

No.6 回答者： GooUserラック 回答日時： 2017/02/09 13:01

時間に関してですが全比較で合っていたら次の項目を比較なのでどうしても時間がかかります。

比較するものを事前にソートしておくと比較しなければいけない部分が減りますので10分の1以下にはなりそうです（もちろん比較方法を変えないといけませんけど）。元に戻せば良いというならば、使っていない列に元の行番号を入れて、処理後にそれでソートしてその列をクリアしてしまえば何もなかったようにも出来ます。Ｌ列あたりを使っても良いですか？

この回答へのお礼

ご回答ありがとうございます。

テスト環境なので、他の列をつかっても構わないです。
よろしくお願いします。

お礼日時：2017/02/09 16:37

No.4 回答者： GooUserラック 回答日時： 2017/02/09 12:47

とりあえず一部だけ説明しておきます。

-----------------------------------------------------------------------
多分ですが、配列に代入されたときにどうなるかが判りにくいと思います。

たとえば「d = Range("D2:G20")」または「d = Range(Cells(2, 4), Cells(20, 7))」の場合
「Range("D2")」（左上）の値は「d(1, 1)」に入ります。
「Range("G2")」（右上）の値は「d(1, 4)」に入ります。
「Range("D20")」（左下）の値は「d(19, 1)」に入ります。
「Range("G20")」（右下）の値は「d(19, 4)」に入ります。

感じとしては代入すると、A1セルを選択した所にコピーされたようになるだけです。
※ タイトル行を抜いたので判りにくかったかも知れません。
-----------------------------------------------------------------------
符号がプラス(0)に対してマイナス(1)のもので同じものがあったら
・符号を別なもの(-1)にして次回対象にならないようにする。（s(m, 1) = -1）
・符号がプラスの行の「判定1」の列にフラグ(1)を代入します。（f(p, 1) = 1）
・符号がマイナスの行の「判定2」の列にフラグ(1)を代入します。（f(m, 2) = 1）
・マイナスのループを抜ける。（Exit For）
-----------------------------------------------------------------------

この回答へのお礼

ご回答ありがとうございます。

がんばって理解できるように勉強します。

お礼日時：2017/02/09 14:20

No.3 回答者： GooUserラック 回答日時： 2017/02/08 19:49

データが多いので配列を使ってみました。

-----------------------------------------------------------------------------
Sub Sample()
Dim d As Variant
Dim s As Variant
Dim f As Variant
Dim e As Long
Dim p As Long
Dim m As Long
e = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(2, 10), Cells(e, 11)).ClearContents
d = Range(Cells(2, 2), Cells(e, 5))
s = Range(Cells(2, 8), Cells(e, 8))
f = Range(Cells(2, 10), Cells(e, 11))
For p = 1 To e - 1
If s(p, 1) = 0 Then
For m = 1 To e - 1
If s(m, 1) = 1 Then
If d(p, 1) = d(m, 1) Then
If d(p, 2) = d(m, 2) Then
If d(p, 3) = d(m, 3) Then
If d(p, 4) = d(m, 4) Then
s(m, 1) = -1
f(p, 1) = 1
f(m, 2) = 1
Exit For
End If
End If
End If
End If
End If
Next
End If
Next
Range(Cells(2, 10), Cells(e, 11)) = f
MsgBox ("終了しました")
End Sub
-----------------------------------------------------------------------------
※ ソートをかけて良ければさらに早く出来ると思います。

この回答へのお礼

ありがとうございました。
充分に早くできます。10万桁でも30秒ほどで終わりました。
ある程度理解できるのですが、当方の環境にあわすため
中身を少し教えていただけませんか？

For p = 1 To e - 1
If s(p, 1) = 0 Then
For m = 1 To e - 1
If s(m, 1) = 1 Then
If d(p, 1) = d(m, 1) Then
If d(p, 2) = d(m, 2) Then
If d(p, 3) = d(m, 3) Then
If d(p, 4) = d(m, 4) Then
s(m, 1) = -1
f(p, 1) = 1
f(m, 2) = 1
Exit For

このあたり

お礼日時：2017/02/09 11:18

No.2 回答者： tatsu99 回答日時： 2017/02/08 19:24

このフラグを立てたいシートのシート名は何ですか。

Sheet1で良いですか。

この回答へのお礼

同じシート内です

お礼日時：2017/02/09 14:23

No.1 回答者： GooUserラック 回答日時： 2017/02/08 17:32

「拠点」「日付」「金額」「商品コード」と共に「伝票番号」は同じでなくても良いのでしょうか？