エクセルを使って、入金明細と売上明細の照合をする時に便利＆時短なVBAを紹介します。
伝票番号などのキーとなる項目を「辞書」に格納して照合していきます。
毎月毎月、大量の入金明細を自社の売上データと照合しないといけないんです。
ものすごい作業時間だし、目も痛くなるし、肩も凝るし、消込みにミスがあると最悪のパターンで最初からやり直すハメになるしで、なんとかなりませんか。
今月が終わったと思ったらすぐに次月のデータが届きますよね。
こういた規則性のあるデータ同士の照合はある程度機械にまかせて、最後の手直しだけ人の手で行えるようにしてしまいましょう。
上手くできる方法があるんですね！
基本的な例題で紹介するので、あとは実態に沿うように変更してみてください。どう変更したらいいかわからない場合は質問にお答えしますよ。
サンプル例題
Sheet1：自社の売上データ
A列：売上日付
B列：伝票番号
C列：商品名
D列：金額
Sheet2：取引先からの入金データ
A列：伝票番号
B列：仕入日付
C列：商品コード
D列：商品名
E列：金額
Sheet1、Sheet2ともに1行目はタイトル
キーとなるタイトルは「伝票番号」とする
売上データと入金データを照合するVBA
Sub 照合()
Dim myDic As Object
Dim myKey, c, varData As Variant
Dim a, b, e, r, g, h, j As Long
Dim aa, ab, ba, bb As Range
Set myDic = CreateObject(“Scripting.Dictionary”)
With Sheets(“Sheet1”)
varData = .Range(“B2”, .Range(“B” & Rows.Count).End(xlUp)).Value
End With
For Each c In varData
If Not c = Empty Then
If Not myDic.Exists(c) Then
myDic.Add c, Null
End If
End If
Next
With Sheets(“Sheet2”)
varData = .Range(“A2”, .Range(“A” & Rows.Count).End(xlUp)).Value
End With
For Each c In varData
If Not c = Empty Then
If Not myDic.Exists(c) Then
myDic.Add c, Null
End If
End If
Next
myKey = myDic.Keys
e = Worksheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Row
r = Worksheets(“Sheet2”).Cells(Rows.Count, 3).End(xlUp).Row
Sheets(“Sheet1”).Select
Set aa = Range(Cells(2, 2), Cells(e, 2))
Set ab = Range(Cells(2, 4), Cells(e, 4))
Sheets(“Sheet2”).Select
Set ba = Range(Cells(2, 1), Cells(r, 1))
Set bb = Range(Cells(2, 5), Cells(r, 5))
For i = 0 To myDic.Count – 1
a = WorksheetFunction.SumIf(aa, myKey(i), ab)
b = WorksheetFunction.SumIf(ba, myKey(i), bb)
If a <> b Then
g = Worksheets(“Sheet3”).Cells(Rows.Count, 1).End(xlUp).Row
h = Worksheets(“Sheet3”).Cells(Rows.Count, 5).End(xlUp).Row
j = Application.WorksheetFunction.Max(g, h)
Rows(“1:1”).AutoFilter 2, myKey(i)
If WorksheetFunction.CountIf(ActiveSheet.Range(Cells(1, 2), Cells(e, 2)), myKey(i)) > 0 Then
Range(Cells(2, 1), Cells(e, 4)).Copy Sheets(“Sheet3”).Cells(j + 1, 1)
End If
Selection.AutoFilter
Rows(“1:1”).AutoFilter 1, myKey(i)
If WorksheetFunction.CountIf(ActiveSheet.Range(Cells(1, 1), Cells(r, 1)), myKey(i)) > 0 Then
Range(Cells(2, 1), Cells(r, 1)).Copy Sheets(“Sheet3”).Cells(j + 1, 6)
Range(Cells(2, 2), Cells(r, 2)).Copy Sheets(“Sheet3”).Cells(j + 1, 5)
Range(Cells(2, 4), Cells(r, 5)).Copy Sheets(“Sheet3”).Cells(j + 1, 7)
End If
End If
Next i
Set myDic = Nothing
g = Worksheets(“Sheet3”).Cells(Rows.Count, 1).End(xlUp).Row
h = Worksheets(“Sheet3”).Cells(Rows.Count, 5).End(xlUp).Row
j = Application.WorksheetFunction.Max(g, h)
Sheets(“Sheet3”).Select
Cells(1, 9).Copy
Range(Cells(2, 9), Cells(j, 9)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range(“A1”).Select
End Sub
コメント