電子帳簿取込み君

説明

電子帳簿保存法対応！

新しいシステムを導入する手間、費用がないという方向けに電子帳簿をボタン一つで自動で取込み、索引簿へ自動記帳、各証憑別のフォルダに移動してくれる簡単なシステムを紹介します。

削除・訂正などの記録はできませんので必ず事務処理規定を別に用意してください。

※使用の際はすべて自己責任にてご使用ください。

更新記録

2024/3/10追記

実行時エラー52問題解決しました。

onedriveに同期の上、office365のエクセルでマクロを実行すると起こる症状のようです。

プログラムを修正の上アップロードしましたので宜しければそのままお使いください。

旧バージョンをお使いの状態で上記環境に移行した場合は実行時エラー52が発生いたしますのでその場合はお手数ですが、onedriveが同期しない場所(USBやCドライブに新たなフォルダを作成するなど)で実行するか、最新の電子帳簿マクロに入れ替えてもう一度帳票ファイルを登録しなおしてください。

修正にあたり

「リベラボ」さん

https://tsurutoro.com/vba-trouble/

こちらの記事を参考にさせて頂きました。

2024/2/15追記

索引簿の登録行数が3万行を超えてくるとプログラムが誤動作を起こしますので軽微なエラー対策を追加しました。

以前までのプログラムでも3万件を超えない範囲でお使い頂ければ問題なく動作いたします。

もし超える場合は新たな索引簿に切り替えてください。

2024/3/2追記

電子帳簿マクロ旧バージョンをお使いの方へ

電子帳簿フォルダの場所を移動するとリンクが無効になるというバグが発覚したのでリンク更新の修正プログラムを配布します。

修正手順は動画をご覧になって頂ければと思います。

修正ソースプログラム

お手数おかけいたします。

今から作成するという方はすでにプログラムを修正しておりますのでそのままお使いください。

すいません、すいません、すいません。

なお、ハイパーリンクに関するプログラムについては凛明館さんの記事を参考に作成いたしました。

広告

こちらの国税庁の電子帳簿索引簿のサンプルを少し改造して

↑国税庁ホームページより↑

大量にたまった電子証憑を

取込みボタン一つで

↓↓↓

自動で索引簿へ記帳

さらに任意のフォルダへと自動で割り分けてくれるというシステムになります。

目次

１・ファイル名の指定方法

２・索引簿のエクセルファイルの作成

３・エクセルファイルのマクロ有効化

４・フォルダ構成

５・開発タブの表示

６・マクロ実行ボタンの設置

７・VBEエディタ起動

８・Microsoft Scrpting Runtimeの設定

９・プログラムの設置

１０・テスト

ソースプログラム

こちらの手順で説明していきます。

必要に応じて各項目へ飛んでいただいて大丈夫です。

ソースプログラムは一番下にあります。

ソースプログラム

マクロ有効化手前までの状態のものをダウンロードできる状態にしてありますので、必要ならダウンロードしてください。

続きましてこちらはマクロを有効化した状態のものになりますので、セキュリティ上何も問題ないという方はダウンロードしてください。

動作に関しては保証できません。使用に関して発生したいかなる損害に関してもすべて自己責任にてご使用ねがいます。

zipフォルダになりますので、フォルダ上で右クリック→すべて展開して、展開された方のフォルダから取り出して使ってください。

電子帳簿マクロというフォルダが続きますので中にある「2023年度」というフォルダをそのまま取り出して任意のフォルダへコピーすれば使いやすいと思われます。

続きましてこちらはファイル移動時に内容部分を省略したくないというリクエストがありましたので、ファイル名修正しないバージョンを作成しました。

マクロを有効化した状態のものになりますので、セキュリティ上何も問題ないという方はダウンロードしてください。

動作に関しては保証できません。使用に関して発生したいかなる損害に関してもすべて自己責任にてご使用ねがいます。

zipフォルダになりますので、フォルダ上で右クリック→すべて展開して、展開された方のフォルダから取り出して使ってください。

電子帳簿マクロBというフォルダが続きますので中にある「2023年度」というフォルダをそのまま取り出して任意のフォルダへコピーすれば使いやすいと思われます。

使用方法

１・ファイル名の指定方法

まず先に電子証憑のファイル名ですが

例：R5.3.4_9700_日本株式会社_領収書_消耗品類

のようにしてください。

日付_金額_会社名_種類_内容

のような感じです。

１・日付はカンマで区切ります。西暦でも大丈夫です。

２・日付と金額は必ず半角で入力してください。

３・それぞれをアンダーバーでつないでください。

４・アンダーバーは区切りの目印なので他の会社名や内容にアンダーバーを含まないでください。

５・最後の内容は何もいれなくても大丈夫ですが、アンダーバーだけはつけてください。

例：R5.3.4_9700_日本株式会社_領収書_

↑最後のアンダーバーはつける↑

こんな感じでお願いします。

２・索引簿のエクセルファイルの作成

次の内容のエクセルファイルを作成してください。

ただ項目名を入れただけのエクセルファイルになります。

セルの幅などはだいたいで大丈夫ですが、項目名とセルの場所は見本と変わらないように入力してください。

お好みでフィルター、セルの固定などをすれば、なお使いやすくなると思われます。

フィルター設定の仕方・・・項目名のセルをドラッグで選択してデータタブ→フィルターボタンで設定

ウィンドウ枠の固定・・・A2セルを選択して表示タブ→ウィンドウ枠の固定→ウィンドウ枠の固定で設定

３・エクセルファイルのマクロ有効化

次にこちらのファイルをエクセルマクロつきファイルで保存していきます。

名前を付けて保存からファイルの種類を選択(名前は仮に電子帳簿索引簿としておきます)

ファイルの種類をマクロ有効ブックにして保存します。

こんな感じですね。

!ビックリマークがついている方がマクロ有効エクセルファイルになります。

前のファイルはもう使わないので消しても大丈夫です。

４・フォルダ構成

次に電子帳簿用のフォルダを作成して以下のようなフォルダ構成にしてください。

大元のフォルダを電子帳簿として

とりあえず年度ごとに作成

年度ごとに索引簿と領収書など各証憑別のフォルダを作る

さきほどのファイル名の

例：R5.3.4_9700_日本株式会社_領収書_消耗品類

この領収書にあたる部分のフォルダを作ればそこに仕分けされます。

※別に年度ごとにわけないで使い続ける事もできます

５・開発タブの表示

そしらた今度は先ほどのマクロファイル「電子帳簿索引簿」を開いて開発タブを設置していきます。

ファイルメニューから

オプションを選択

リボンのユーザー設定を選択

右側の開発のトコロにチェックをしてＯＫすれば完了です。

開発タブが表示されました。

広告

６・マクロ実行ボタンの設置

実行ボタンを設置していきます。

１・開発タブに合わせて

２・挿入から

３・左上のボタンのような部分をクリック

カーソルが十字に変わるので適当な場所でドラッグ

出てきた画面はそのままＯＫ

実行ボタンが設置されます。

そのままの状態でボタンの編集ができます。

テキストの部分にカーソルを合わせてクリックすればテキストも編集できます。

ボタンの編集状態を解除するには何もないセルをクリック

ボタンの上で右クリックすれば再び編集状態になります。

とりあえず取込ボタンとして左上に設置しておきました。

７・VBEエディタ起動

プログラムを編集できる状態にします。

Visual Basicをクリック

Microsoft Visual Basic for Applicationsというプログラムを書くためのエディターが立ち上がります。

挿入から標準モジュールをクリック

この白い部分にプログラムを書いていきます。

８・Microsoft Scrpting Runtimeの設定

そのままでもプログラミングできますが、今回は他のファイルを操作する為の「Microsoft Scripting Runtime」という特別な機能を追加します。

ツールをクリックして参照設定をクリック

機能を追加する画面が表示されます。

「Microsoft Scripting Runtime」が現れるまで下の方へ下がっていきます。

真ん中よりちょっと上にありますので、チェックしてOKで閉じます。

９・プログラムの設置

プログラムを貼り付けていきます。

下のソース１ここからソース１ここまでの部分をコピーしてプログラムを編集する部分に貼り付けてください。

※ソース２の部分を含めないようにコピーしてください

コピーして

貼り付けます。

次にこの左側のThisWorkBookという部分をダブルクリックして

下のソース２ここからソース２ここまでの部分をコピー

※ソース１の部分を含めないでください

貼り付けます。

これでプログラム部分はおしまいです。

上書き保存して

VBAエディタの×ボタンでVBAエディタだけ閉じる事ができます。

最後にボタンに今作ったマクロを登録していきます。

ボタンの上で右クリック

マクロの登録をクリック

今作った「WriteData」というマクロを選べるようになるので選択してOK

これで準備完了です。

１０・テスト

人が作ったマクロをそのまま試すのはナンだと思いますのでテストしてみましょう。

これからは受け取った電子証憑をこちらの未分類フォルダへどんどん入れていきます。

ここで先に説明した

例：R5.3.4_9700_日本株式会社_領収書_消耗品類

のようなファイル名に形式を変更して、さきほど設置した取込ボタンで取り込んでいくという手順になります。

テストとして未分類フォルダに次のファイルをテキストファイルで適当に作っておいてみました。

ひとつはきちんとファイル名を整えたものともうひとつは適当なファイル名を付けたものになります。

電子帳簿索引簿のファイルを開いて取り込んでいきましょう。

話はそれますがマクロ付きファイルを開いた時にこのような警告がでる事があります。

危険なマクロを実行させないようにする為のものですが、今回は自分で作っているマクロなのでそのまま「コンテンツの有効化」で大丈夫です。

取込みボタンを押すと・・・

ひとつは正常に取り込まれて、ファイル名が不正なファイルは取り込まれず警告がでるようになっております。

右手のリンクを押すと

そのままファイルの内容を確認する事ができます。

領収書フォルダを確認すると・・・

ファイルが移動されているのが確認できますね！

間違えて取り込んだ時は

エクセルファイルの方は間違えた行をそのまま削除してください。

そして取り込んだファイルを再び未分類フォルダに移してファイル名を修正して再度取り込んでください。

※取り込んだ際に最後の内容の部分は削られるようにプログラムを設定しております。

'ソースプログラム

'ソース１ここから
Option Explicit

Sub writeData()
    Dim fso As FileSystemObject
    Dim bookpath As String
    Dim filetype As String
    Dim extfilename As String
    Dim extname As String
    Dim filename As String
    Dim ary As Variant
    Dim count As Integer
    Dim count2 As Integer
    Dim columnposi As Integer
    Dim pathtmp As Variant
    Dim pathary As Variant
    
    Set fso = New FileSystemObject
    
    If Left(ThisWorkbook.Path, 5) = "https" Then
        pathtmp = ThisWorkbook.Path
        pathary = Split(pathtmp, "/")
        bookpath = Environ("UserProfile") & "\OneDrive\" & pathary(UBound(pathary) - 1) & "\" & pathary(UBound(pathary))
    Else
        bookpath = ThisWorkbook.Path
    End If
    
    filetype = "\*.*"
    columnposi = 1
    
    '(エラー対策)未分類フォルダ存在確認
    '未分類という名前のフォルダがある所でだけ
    'マクロが実行されるようにする
    If Dir(bookpath & "\未分類", vbDirectory) = "" Then
        MsgBox "指定のフォルダがないので中止します"
        Exit Sub
    End If
    
    '(エラー対策)
    'ファイルの最初のセルが日付・取引先・価格・種別・備考・リンク
    If Not (Cells(1, 1 + columnposi).Value = "日付" And _
        Cells(1, 2 + columnposi).Value = "金額" And _
        Cells(1, 3 + columnposi).Value = "取引先" And _
        Cells(1, 4 + columnposi).Value = "備考" And _
        Cells(1, 5 + columnposi).Value = "内容" And _
        Cells(1, 6 + columnposi).Value = "リンク") Then
        MsgBox "指定のファイルではないので中止します"
        Exit Sub
    End If

    '追加(エラー対策)
    '登録件数が3万件を超えた場合終了する
    count = 1
    Do While Cells(count, 1 + columnposi).Value <> ""
        count = count + 1
    Loop
    If count > 30000 Then
        MsgBox "登録可能件数をオーバーしたので終了します"
        MsgBox "新しい電子帳簿索引簿を作成してください"
        Exit Sub
    End If
    
    '先頭ファイル名取得
    extfilename = Dir(bookpath & "\未分類" & filetype, vbNormal)

    'ファイル名が空になるまで繰り返し
    '(全てのファイルを取得するまで)
    Do While extfilename <> ""
        
        'ファイル名をアンダーバー_で分解する為に
        '拡張子を除いた部分だけのファイル名を取得する
        filename = fso.GetBaseName(extfilename)
        '拡張子名も取得する
        extname = fso.GetExtensionName(extfilename)

        'ファイル名をアンダーバー_で分解
        ary = Split(filename, "_")
        'ファイル名の日付部分をr5.1.1→r5/1/1のように変換
        ary(0) = Replace(ary(0), ".", "/")
        
        '(エラー対策)
        'ファイル名がアンダーバーで５つに分割されていれば
        '処理に移る
        If UBound(ary) = 4 Then
        
            '(エラー対策)
            '配列0番目が日付データ
            'かつ配列1番目が数値データ
            'かつ同じ名前のファイルがない
            'かつ帳票種別のフォルダが存在している
            '場合に取り込み、ファイル移動処理を行う
            Dim Target As String
            Dim target2 As String
            Target = bookpath & "\" & ary(3)
            target2 = bookpath & "\" & ary(3) & "\" & Replace(ary(0), "/", ".") & "_" & ary(1) & "_" & ary(2) & "_" & ary(3) & "." & extname
            
            If IsDate(ary(0)) And IsNumeric(ary(1)) And fso.FolderExists(Target) And Not (fso.FileExists(target2)) Then
                
                count = 1
                count2 = 1
    
                '電子帳簿の最終行を取得
                Do While Cells(count, 1 + columnposi).Value <> ""
                    count = count + 1
                Loop
    
                'ファイル名のデータを電子帳簿に書き込む
                For count2 = 0 To UBound(ary)
                    Cells(count, count2 + 1 + columnposi).Value = ary(count2)
                Next
                
                'ファイル名変更処理
                'ファイル名最後の備考にあたる部分を削除する
                Dim tmp_str As Variant
                Dim tmp_str2 As Variant
                tmp_str = bookpath & "\" & "未分類" & "\" & extfilename
                tmp_str2 = bookpath & "\" & "未分類" & "\" & Replace(ary(0), "/", ".") & "_" & ary(1) & "_" & ary(2) & "_" & ary(3) & "." & extname
                
                Name tmp_str As tmp_str2
                extfilename = Replace(ary(0), "/", ".") & "_" & ary(1) & "_" & ary(2) & "_" & ary(3) & "." & extname
                filename = fso.GetBaseName(extfilename)
    
                'ハイパーリンクを設定する
                Dim hyplink As Hyperlink
                Set hyplink = ActiveSheet.Hyperlinks.Add(Anchor:=Range(Cells(count, 6 + columnposi).Address), _
                    Address:="", ScreenTip:="\" & ary(3) & "\" & extfilename, TextToDisplay:=ary(3) & "\" & extfilename)
                
                'ファイルを各フォルダへと移動
                Call fso.MoveFile(bookpath & "\" & "未分類" & "\" & extfilename, bookpath & "\" & ary(3) & "\")
            Else
                MsgBox filename & vbCrLf & "ファイルが適合しておりません"
            End If
        Else
            MsgBox filename & vbCrLf & "ファイルが適合しておりません"
        End If
        
        '次のファイル名を取得
        extfilename = Dir()
    Loop

    count = 1

    '表の日付と金額の見た目を整える
    Do While Cells(count, 1 + columnposi).Value <> ""
        Cells(count, 1 + columnposi).Value = Format(Cells(count, 1 + columnposi).Value, "yyyy/mm/dd")
        Cells(count, 2 + columnposi).NumberFormatLocal = "\#,##;-\#,##0"
        count = count + 1
    Loop

    '日付順に並び変えをする
    '(20列まで対応可)
    ActiveSheet.Range(Cells(2, 1 + columnposi), Cells(count, 20 + columnposi)) _
    .Sort key1:=ActiveSheet.Cells(2, 1 + columnposi), order1:=xlAscending
    
    '通し番号をふる
    If columnposi = 1 Then
        Columns(1).Clear
        For count2 = 2 To count - 1
            Cells(count2, 1).Value = "=row()-1"
        Next
    End If
    
    Set fso = Nothing

End Sub
'ソース１ここまで

'ソース２ここから
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
    Dim bookpath As String
    Dim pathtmp As Variant
    Dim pathary As Variant
    
    If Left(ThisWorkbook.Path, 5) = "https" Then
        pathtmp = ThisWorkbook.Path
        pathary = Split(pathtmp, "/")
        bookpath = Environ("UserProfile") & "\OneDrive\" & pathary(UBound(pathary) - 1) & "\" & pathary(UBound(pathary))
    Else
        bookpath = ThisWorkbook.Path
    End If
    
    With CreateObject("Wscript.Shell")
    .Run Chr(34) & bookpath & Target.ScreenTip & Chr(34), 4, False
    End With
End Sub
'ソース２ここまで

'修正ソースプログラム

電子帳簿マクロ初期バージョンをお使いの方向けのリンク修正プログラムになります。

新しく作成する方はこちらのマクロは使用しないでください。

'修正ソースここから
Option Explicit

Sub writeData()
    Dim fso As FileSystemObject
    Dim bookpath As String
    Dim filetype As String
    Dim extfilename As String
    Dim extname As String
    Dim filename As String
    Dim ary As Variant
    Dim count As Integer
    Dim count2 As Integer
    Dim columnposi As Integer

    Dim ans As Variant
    Dim tmpfilename As Variant
    
    Set fso = New FileSystemObject
    bookpath = ThisWorkbook.Path

    filetype = "\*.*"
    columnposi = 1
    
    '(エラー対策)未分類フォルダ存在確認
    '未分類という名前のフォルダがある所でだけ
    'マクロが実行されるようにする
    If Dir(bookpath & "\未分類", vbDirectory) = "" Then
        MsgBox "指定のフォルダがないので中止します"
        Exit Sub
    End If
    
    '(エラー対策)
    'ファイルの最初のセルが日付・取引先・価格・種別・備考・リンク
    If Not (Cells(1, 1 + columnposi).Value = "日付" And _
        Cells(1, 2 + columnposi).Value = "金額" And _
        Cells(1, 3 + columnposi).Value = "取引先" And _
        Cells(1, 4 + columnposi).Value = "備考" And _
        Cells(1, 5 + columnposi).Value = "内容" And _
        Cells(1, 6 + columnposi).Value = "リンク") Then
        MsgBox "指定のファイルではないので中止します"
        Exit Sub
    End If

    '追加(エラー対策)
    '登録件数が3万件を超えた場合終了する
    count = 1
    Do While Cells(count, 1 + columnposi).Value <> ""
        count = count + 1
    Loop
    If count > 30000 Then
        MsgBox "登録可能件数をオーバーしたので終了します"
        MsgBox "新しい電子帳簿索引簿を作成してください"
        Exit Sub
    End If

    ans = InputBox("1:取込 2:リンク更新")
    
    If ans = 2 Then
        count = 1
        Do While Cells(count, 1 + columnposi).Value <> ""
            If Cells(count, 6 + columnposi).Hyperlinks.count = 1 Then
                If Cells(count, 6 + columnposi).Hyperlinks(1).ScreenTip <> "" Then
                    tmpfilename = Split(Cells(count, 6 + columnposi).Hyperlinks(1).ScreenTip, "\" & Cells(count, 4 + columnposi).Value & "\")(1)
                    Cells(count, 6 + columnposi).Hyperlinks.Delete
                    Dim hyplink2 As Hyperlink
                    Set hyplink2 = ActiveSheet.Hyperlinks.Add(Anchor:=Range(Cells(count, 6 + columnposi).Address), _
                        Address:="", ScreenTip:=bookpath & "\" & Cells(count, 4 + columnposi).Value & "\" & tmpfilename, TextToDisplay:=Cells(count, 4 + columnposi).Value & "\" & tmpfilename)
                End If
            End If
            count = count + 1
        Loop
    ElseIf ans = 1 Then


        '先頭ファイル名取得
        extfilename = Dir(bookpath & "\未分類" & filetype, vbNormal)

        'ファイル名が空になるまで繰り返し
        '(全てのファイルを取得するまで)
        Do While extfilename <> ""
            
            'ファイル名をアンダーバー_で分解する為に
            '拡張子を除いた部分だけのファイル名を取得する
            filename = fso.GetBaseName(extfilename)
            '拡張子名も取得する
            extname = fso.GetExtensionName(extfilename)

            'ファイル名をアンダーバー_で分解
            ary = Split(filename, "_")
            'ファイル名の日付部分をr5.1.1→r5/1/1のように変換
            ary(0) = Replace(ary(0), ".", "/")
            
            '(エラー対策)
            'ファイル名がアンダーバーで５つに分割されていれば
            '処理に移る
            If UBound(ary) = 4 Then
            
                '(エラー対策)
                '配列0番目が日付データ
                'かつ配列1番目が数値データ
                'かつ同じ名前のファイルがない
                'かつ帳票種別のフォルダが存在している
                '場合に取り込み、ファイル移動処理を行う
                Dim Target As String
                Dim target2 As String
                Target = bookpath & "\" & ary(3)
                target2 = bookpath & "\" & ary(3) & "\" & Replace(ary(0), "/", ".") & "_" & ary(1) & "_" & ary(2) & "_" & ary(3) & "." & extname
                
                If IsDate(ary(0)) And IsNumeric(ary(1)) And fso.FolderExists(Target) And Not (fso.FileExists(target2)) Then
                    
                    count = 1
                    count2 = 1
        
                    '電子帳簿の最終行を取得
                    Do While Cells(count, 1 + columnposi).Value <> ""
                        count = count + 1
                    Loop
        
                    'ファイル名のデータを電子帳簿に書き込む
                    For count2 = 0 To UBound(ary)
                        Cells(count, count2 + 1 + columnposi).Value = ary(count2)
                    Next
                    
                    'ファイル名変更処理
                    'ファイル名最後の備考にあたる部分を削除する
                    Dim tmp_str As Variant
                    Dim tmp_str2 As Variant
                    tmp_str = bookpath & "\" & "未分類" & "\" & extfilename
                    tmp_str2 = bookpath & "\" & "未分類" & "\" & Replace(ary(0), "/", ".") & "_" & ary(1) & "_" & ary(2) & "_" & ary(3) & "." & extname
                    
                    Name tmp_str As tmp_str2
                    extfilename = Replace(ary(0), "/", ".") & "_" & ary(1) & "_" & ary(2) & "_" & ary(3) & "." & extname
                    filename = fso.GetBaseName(extfilename)
        
                    'ハイパーリンクを設定する
                    Dim hyplink As Hyperlink
                    Set hyplink = ActiveSheet.Hyperlinks.Add(Anchor:=Range(Cells(count, 6 + columnposi).Address), _
                        Address:="", ScreenTip:=bookpath & "\" & ary(3) & "\" & extfilename, TextToDisplay:=ary(3) & "\" & extfilename)
                    
                    'ファイルを各フォルダへと移動
                    Call fso.MoveFile(bookpath & "\" & "未分類" & "\" & extfilename, bookpath & "\" & ary(3) & "\")
                Else
                    MsgBox filename & vbCrLf & "ファイルが適合しておりません"
                End If
            Else
                MsgBox filename & vbCrLf & "ファイルが適合しておりません"
            End If
            
            '次のファイル名を取得
            extfilename = Dir()
        Loop

        count = 1

        '表の日付と金額の見た目を整える
        Do While Cells(count, 1 + columnposi).Value <> ""
            Cells(count, 1 + columnposi).Value = Format(Cells(count, 1 + columnposi).Value, "yyyy/mm/dd")
            Cells(count, 2 + columnposi).NumberFormatLocal = "\#,##;-\#,##0"
            count = count + 1
        Loop

        '日付順に並び変えをする
        '(20列まで対応可)
        ActiveSheet.Range(Cells(2, 1 + columnposi), Cells(count, 20 + columnposi)) _
        .Sort key1:=ActiveSheet.Cells(2, 1 + columnposi), order1:=xlAscending
        
        '通し番号をふる
        If columnposi = 1 Then
            Columns(1).Clear
            For count2 = 2 To count - 1
                Cells(count2, 1).Value = "=row()-1"
            Next
        End If
        
        Set fso = Nothing

    Else
        MsgBox "番号が不正です"
    End If

End Sub
'修正ソースここまで