![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?e8efa67)
![](http://oshiete.xgoo.jp/images/v2/common/profile/M/noimageicon_setting_14.png?e8efa67)
No.5ベストアンサー
- 回答日時:
No2です。
シート名に対する回答がないので、現在表示されているシートに対して操作を行います。このマクロと無関係のシートを表示した状態で、このマクロを実行するとそのシートが破壊されますので
注意ください。
こちらの環境では、約10万件で8秒で終わっています。
以下のマクロを標準モジュールへ登録してください。
------------------------------------------------------------
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
---------------------------------------------------
申しわけございません。
同じ回答者さんだと思ってスルーしていました。
ご回答ありがとうございます。
教えていただいたコードでテストしまして
うまくいきました。時間も早かったです。
No.6
- 回答日時:
時間に関してですが全比較で合っていたら次の項目を比較なのでどうしても時間がかかります。
比較するものを事前にソートしておくと比較しなければいけない部分が減りますので10分の1以下にはなりそうです(もちろん比較方法を変えないといけませんけど)。元に戻せば良いというならば、使っていない列に元の行番号を入れて、処理後にそれでソートしてその列をクリアしてしまえば何もなかったようにも出来ます。L列あたりを使っても良いですか?No.4
- 回答日時:
とりあえず一部だけ説明しておきます。
-----------------------------------------------------------------------
多分ですが、配列に代入されたときにどうなるかが判りにくいと思います。
たとえば「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)
-----------------------------------------------------------------------
No.3
- 回答日時:
データが多いので配列を使ってみました。
-----------------------------------------------------------------------------
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
このあたり
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
このQ&Aを見た人はこんなQ&Aも見ています
-
【お題】甲子園での思い出の残し方
「球場の砂を持って帰る」はもう古いと思った高校球児が、甲子園で負けた際に、思い出に残そうと思って行ったこと
-
フラグについて
Visual Basic(VBA)
-
VBAで処理フラグの立て方
Visual Basic(VBA)
-
エクセル:セル内の文字列の最後の「,]を消したい。
その他(Microsoft Office)
-
-
4
EXCELのVBAでRange(A1:C4")を変数にする方法を教え"
Visual Basic(VBA)
-
5
どうやってもFor文を抜けてしまいます…(VBA)
Excel(エクセル)
-
6
フラグを立てた物のみを別シートへ反映したい
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
首吊りどこ締めるの
-
白血球が多いとどんな心配があ...
-
彼女のことが好きすぎて彼女の...
-
勃起する時って痛いんですか? ...
-
甲状腺が腫れているが血液検査...
-
エクセルのラベルの値(文字列...
-
EXCELで条件付き書式で空白セル...
-
検便についてです。 便は取れた...
-
リンク先のファイルを開かなく...
-
エクセル指定した範囲からラン...
-
2つの数値のうち、数値が小さい...
-
エクセルで数式の答えを数値と...
-
これって喉仏ですか? 私は女性...
-
小数点以下を繰り上げたものを...
-
ある範囲のセルから任意の値を...
-
Excel 0目標に対して数字があ...
-
イタリアから帰国する際、肉製...
-
excelのIF関数 A,Bの大きいほ...
-
エクセルでエラーが出て困って...
-
エクセルで空白セルを含む列の...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
首吊りどこ締めるの
-
白血球が多いとどんな心配があ...
-
彼女のことが好きすぎて彼女の...
-
検便についてです。 便は取れた...
-
勃起する時って痛いんですか? ...
-
精子が黄色?
-
エクセル指定した範囲からラン...
-
小数点以下を繰り上げたものを...
-
EXCELで条件付き書式で空白セル...
-
ある範囲のセルから任意の値を...
-
甲状腺が腫れているが血液検査...
-
これって喉仏ですか? 私は女性...
-
2つの数値のうち、数値が小さい...
-
精液の落とし方を教えてください
-
精子に血が・・・
-
EXCELで式からグラフを描くには?
-
アクエリアスが苦く感じる
-
Excelで""で囲む方法
-
値が入っているときだけ計算結...
-
風俗店へ行く前のご飯
おすすめ情報
伝票番号は変わることもありますので、同じでなくてもいいです。
すみません。検証したのは10000桁でした。
当方の環境で10万桁で検証しますと、30分程
かかりました。