伝票計上漏れ確認用VBA

投稿者 : IND     投稿日時 : 2025/06/03(Tue) 11:21:37     OS : Windows 11     EXCEL : Office 365

---

経理にVBAを活用したく、試行錯誤しております。

毎月定例で発生する伝票の計上漏れがないかどうかを確認するVBAを組んでみましたが、上手くいきません。
お詳しい方にご教示いただけますと大変助かります。
当方ド素人で、チャットGPTで作成しました。

事前に「伝票起票漏れ確認用取引一覧」というエクセルを作っています。
これは毎月定例で発生する取引明細を一覧にしたものです。
この一覧と、実際に発生した「経費明細」というデータを照合して計上漏れがないか確認します。
照合の方法は、C,G,S,W列が全て共通しているかどうかを確認します（それぞれの列は相手先名称や科目などです）。

【「伝票起票漏れ確認用取引一覧」にはあるが、経費明細に計上がない取引】、つまり毎月発生する取引なのにまだ計上されていない取引について、該当する行を新規シートに張り付ける

という動きにしたかったのですが、実行してみると、該当の行が全て共通している（＝きちんと計上されている）取引まで新規シートに張り付けられてしまいます。
何が原因なのかお教えください。よろしくお願いします。

Sub CheckMissingTransactions()
Dim mainWB As Workbook
Dim checkWB As Workbook
Dim mainWS As Worksheet
Dim checkWS As Worksheet
Dim resultWS As Worksheet
Dim filePath As String
Dim lastRowMain As Long, lastRowCheck As Long
Dim i As Long, j As Long
Dim exists As Boolean
Dim resultRow As Long

' 経費明細書の情報
Set mainWB = ThisWorkbook
Set mainWS = mainWB.Sheets("経費明細書(番組・一般)")

' 比較対象のファイルパス
filePath = "C:\伝票起票漏れチェック\伝票起票漏れ確認用取引一覧.xlsx"

' 伝票起票漏れ確認用取引一覧を開く
On Error Resume Next
Set checkWB = Workbooks.Open(filePath)
If checkWB Is Nothing Then
MsgBox "取引一覧ファイルを開けません。パスが正しいか確認してください。", vbExclamation
Exit Sub
End If
On Error GoTo 0

Set checkWS = checkWB.Sheets(1) ' 一つ目のシートを使用

' データ行数の取得
lastRowMain = mainWS.Cells(mainWS.Rows.Count, "A").End(xlUp).Row
lastRowCheck = checkWS.Cells(checkWS.Rows.Count, "A").End(xlUp).Row

' 結果出力用シートを作成
Set resultWS = mainWB.Sheets.Add(After:=mainWB.Sheets(mainWB.Sheets.Count))
resultWS.Name = "伝票起票漏れリスト"
resultRow = 1

' 見出し行のコピー（1行目が見出しと仮定）
checkWS.Rows(1).Copy Destination:=resultWS.Rows(resultRow)
resultRow = resultRow + 1

' 照合開始
For i = 2 To lastRowCheck ' 取引一覧の2行目から
If checkWS.Cells(i, "A").Value = "明細" Then
exists = False
For j = 2 To lastRowMain
If mainWS.Cells(j, "A").Value = "明細" Then
If Trim(checkWS.Cells(i, "C").Value) = Trim(mainWS.Cells(j, "C").Value) And _
Trim(checkWS.Cells(i, "G").Value) = Trim(mainWS.Cells(j, "G").Value) And _
Trim(checkWS.Cells(i, "S").Value) = Trim(mainWS.Cells(j, "S").Value) And _
Trim(checkWS.Cells(i, "W").Value) = Trim(mainWS.Cells(j, "W").Value) Then
exists = True
Exit For
End If
End If
Next j
If Not exists Then
checkWS.Rows(i).Copy Destination:=resultWS.Rows(resultRow)
resultRow = resultRow + 1
End If
End If
Next i

' 伝票起票漏れがない場合のメッセージ
If resultRow = 2 Then
MsgBox "全ての取引が経費明細書に存在しています。", vbInformation
Application.DisplayAlerts = False
resultWS.Delete
Application.DisplayAlerts = True
Else
MsgBox "伝票起票漏れが " & resultRow - 2 & " 件見つかりました。", vbExclamation
End If

' 後始末
checkWB.Close SaveChanges:=False
End Sub

投稿者 : さんこう     投稿日時 : 2025/06/03(Tue) 14:06:40

---

＞該当の行が全て共通している（＝きちんと計上されている）取引まで新規シートに張り付けられてしまいます。

適当なデータで試しましたが、「という動き」になりました。

データのほうを確認してみてはいかがでしょうか。

投稿者 : ピロリ     投稿日時 : 2025/06/03(Tue) 23:41:13

---

さんこうさんの仰る通り、下の条件が成立しないので、コピペが実行されているはずです。
データを確認して下さい。（全角半角の違い、大文字小文字の違い、スペースの有無、etc.）
　If Trim(checkWS.Cells(i, "C").Value) = Trim(mainWS.Cells(j, "C").Value) And _
　　 Trim(checkWS.Cells(i, "G").Value) = Trim(mainWS.Cells(j, "G").Value) And _
　　 Trim(checkWS.Cells(i, "S").Value) = Trim(mainWS.Cells(j, "S").Value) And _
　　 Trim(checkWS.Cells(i, "W").Value) = Trim(mainWS.Cells(j, "W").Value) Then

ちなみに Trim関数は、文字列の前方・後方の全角半角スペースは削除しますが、文字間のスペースは
削除しません。これはご存じですよね？　要は、Trim("　A　B　") ＝ "A　B" （ ≠ "AB" ）