電子取引データを管理する検索簿をエクセル(VBA)で作成してみました。

ExcelVBA
2023.10.12

2024年1月から本格的にスタートする電子帳簿保存法ですが、私が所属する会社でも対応について検討されました。取引件数や内部の状況を鑑みると新しくシステムを導入するのはハードルが高すぎるという決断になり、業務の流れを整備、事務規定と検索簿を作成し対応することにしました。そこで私は国税庁のホームページから対応についてを確認をしていたところ、参考資料(各種規定等のサンプル)に電子取引に関するものとして検索簿の作成例のエクセルがありましたので、これを参考にVBAを作成し管理してみることにしてみました。2023年10月時点

私が作成した検索簿(エクセルブック)は下記3つのシートで構成しました。

・データ受取 (受け取ったPDFを検索簿へ登録するためのシート、コマンドボタンをクリック時に動作。登録をクリックすると検索簿へレコードを追加します。)

・検索簿 (登録されている書類の一覧を確認するシート、テーブルを使用した表、データ受取シートで登録をクリックすると追加される。また、備考の書類をクリックすると該当ファイルが開きます。)

・設定 (ファイルの管理しているフォルダ等を設定するシート、管理番号は登録したタイミングで1づつ増加します。)

登録が完了すると設定しているフォルダにPDFが保存されます。

・入力① (参照ボタン)

Private Sub CommandButton1_Click()
'参照ボタンクリック
    filepathget
End Sub
Sub filepathget()
'ファイルパスの取得
    Dim myFilePath As String
    myFilePath = Application.GetOpenFilename()
    Range("B2").Value = myFilePath
    
    If Range("B2") = "False" Then
        Range("B2") = ""
    End If
    
End Sub

・入力② (登録)

Private Sub CommandButton2_Click()
    filecopyname
End Sub
Sub filecopyname()
'ファイルの名前を付けて保存
    Dim myFileName As String
    Dim hyplink  As Hyperlink
    Dim N As Long
    
    Do
        '入力内容のチェック
        myFileName = Sheet2.Range("B2") & "\" & Range("B6") & "_" & Format(Range("B3"), "yyyymmdd") & "_" & Range("B5") & "_" & Range("B4") & "_" & Range("B7") & "." & Sheet2.Range("B4")
        If Range("B2") = "" Then
            MsgBox "ファイルが指定されていません。"
            Exit Do
        End If
        
        If Trim(Range("B3")) = "" Then
            MsgBox "日付を入力して下さい", vbExclamation
            Exit Do
        End If
        
        If Trim(Range("B4")) = "" Then
            MsgBox "金額を入力して下さい", vbExclamation
            Exit Do
        End If
        
        If Trim(Range("B5")) = "" Then
            MsgBox "取引先を入力して下さい", vbExclamation
            Exit Do
        End If
        
        If Trim(Range("B7")) = "" Then
            MsgBox "備考には「請求書」や「領収書」等の書類名を入力して下さい", vbExclamation
            Exit Do
        End If
        
        'ファイルのコピーと検索簿の追加
        If Dir(myFileName) <> "" Then
            MsgBox "同じ名前のﾌｧｲﾙが存在します。違うﾌｧｲﾙ名を入力して下さい。"
            Exit Do
        Else
            FileCopy Source:=Range("B2"), _
                Destination:=Sheet2.Range("B2") & "\" & Range("B6") & "_" & Format(Range("B3"), "yyyymmdd") & "_" & Range("B5") & "_" & Range("B4") & "." & Sheet2.Range("B4")
                Range("B2") = ""
                '検索簿への追加
                Sheet3.Range("A2").ListObject.ListRows.Add
                N = Sheet3.Range("A2").ListObject.ListRows.Count
                With Sheet3.Range("A2").ListObject.ListRows(N)
                    .Range(1) = Range("B6")
                    .Range(2) = Range("B3")
                    .Range(3) = Range("B4")
                    .Range(4) = Range("B5")
                    .Range(5) = Range("B7")
                    '.Range(6) = Sheet2.Range("B2") & "\" & Range("B6") & "_" & Format(Range("B3"), "yyyymmdd") & "_" & Range("B5") & "_" & Range("B4") & "." & Sheet2.Range("B4")
                    Set hyplink = ActiveSheet.Hyperlinks.Add(Anchor:=.Range(5), _
                                          Address:=Sheet2.Range("B2") & "\" & Range("B6") & "_" & Format(Range("B3"), "yyyymmdd") & "_" & Range("B5") & "_" & Range("B4") & "." & Sheet2.Range("B4"), _
                                          TextToDisplay:=CStr(.Range(5)))
                End With
                
                '管理番号の増
                Sheet2.Range("B3") = Sheet2.Range("B3") + 1
                Range("B6") = Sheet2.Range("B3")
                
                Exit Do
        End If
    Loop
    
End Sub

今回の入力を行い、経理業務のDXを進めるきっかけになったのではないかと感じ、今後もVBAを使って何かの問題解決に利用できればと思っております。

・ご注意
・掲載されている内容には細心の注意をしてるつもりですが、
間違いやご指摘等がありましたら、「お問い合わせ」からご連絡をいただけますと幸いです。
・掲載されている入力VBAコード等は動作を保証するものではなく、あくまでサンプルとして掲載しております。
・掲載されている入力VBAコード等は自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

・サンプルファイル(自己責任でご使用ください)
※サンプルファイルはコードが入力されておりませんので、上記の各イベントのコードをコピーし貼付して下さい

検索簿ダウンロード

コメント