Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

18115 / 76732

←次へ　｜　前へ→


	【64060】Re:ご協力お願いします。

Hirofumi - 10/1/14(木) 12:25 -


	引用なし

	パスワード

けち付ける様で申し訳ありませんが？

Dictionaryは、1個で善い様な気がします？
前月分のKeyをDictionaryに登録する時間が無駄に成る様な気がしますが？
尚、セルの入出力の位置は、「初心者さん　- 10/1/12(火) 22:19 -」に合わせました

Option Explicit

Sub datacheck_2()

　　Dim dic2 As Object
　　Dim r1 As Long, r2 As Long
　　Dim v1 As Long, v2 As Long
　　Dim key As String
　
　　Dim lngCheck() As Long
　　Dim rngMark As Range
　　
　　Set dic2 = CreateObject("Scripting.Dictionary")
　
　　For r2 = 2 To [O1].End(xlDown).Row
　　　　key = Cells(r2, 15).Value & "_" & Cells(r2, 16).Value
　　　　dic2(key) = r2
　　Next r2
　　ReDim lngCheck(dic2.Count - 1)
　　
　　For r1 = 2 To [B1].End(xlDown).Row
　　　　key = Cells(r1, 2).Value & "_" & Cells(r1, 3).Value
　　　　If dic2.Exists(key) Then
　　　　　　r2 = dic2(key)
　　　　　　v1 = Cells(r1, 7).Value
　　　　　　v2 = Cells(r2, 20).Value
　　　　　　If v1 <> v2 Then
　　　　　　　　Cells(r1, 9).Value = "金額変更"
　　　　　　　　Cells(r1, 10).Value = v2 - v1
　　　　　　　　Cells(r2, 22).Value = "金額変更"
　　　　　　　　Cells(r2, 23).Value = v2 - v1
　　　　　　End If
　　　　　　lngCheck(r2 - 2) = 1
　　　　Else
　　　　　　Cells(r1, 9).Value = "削除"
　　　　End If
　　Next r1
　
　　For r2 = 0 To UBound(lngCheck)
　　　　If lngCheck(r2) = 0 Then
　　　　　　Cells(r2 + 2, 22).Value = "追加"
　　　　End If
　　Next r2
　
　　Set dic2 = Nothing
　
End Sub

0 hits

▼

【64046】ご協力お願いします。 初心者 10/1/12(火) 22:19