【VBA】入出金明細を分類して仕訳バッチまで自働化する

入出金明細のExcelファイルを編集用ファイルに変更する

ダイアログボックスを使用してファイルを選択し、そのファイルを別のフォルダにコピーして、新しいファイル名を「会社名_jouranalN月」で保存する

Option Explicit

Sub CopyFileWithNewName()

    Dim SourceFile As Variant
    Dim TargetFolder As Variant
    Dim CompanyName As String
    Dim MonthStr As String
    Dim NewFileName As String
    Dim FileExtension As String
    Dim fso As Object

    ' ファイル選択ダイアログを表示
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "コピーするファイルを選択してください"
        .AllowMultiSelect = False
        If .Show = -1 Then
            SourceFile = .SelectedItems(1)
        Else
            MsgBox "ファイルが選択されませんでした。処理を終了します。"
            Exit Sub
        End If
    End With

    ' フォルダ選択ダイアログを表示
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "ファイルをコピーするフォルダを選択してください"
        If .Show = -1 Then
            TargetFolder = .SelectedItems(1)
        Else
            MsgBox "フォルダが選択されませんでした。処理を終了します。"
            Exit Sub
        End If
    End With

    ' 会社名と月を入力
    CompanyName = InputBox("会社名を入力してください。", "会社名の入力")
    If CompanyName = "" Then
        MsgBox "会社名が入力されませんでした。処理を終了します。"
        Exit Sub
    End If

    MonthStr = InputBox("月を入力してください。（例: 1月の場合は '1'、10月の場合は '10'）", "月の入力")
    If MonthStr = "" Then
        MsgBox "月が入力されませんでした。処理を終了します。"
        Exit Sub
    End If

    ' 新しいファイル名を作成
    FileExtension = Mid(SourceFile, InStrRev(SourceFile, "."))
    NewFileName = CompanyName & "_jouranal" & MonthStr & "月" & FileExtension

    ' ファイルをコピー
    Set fso = CreateObject("Scripting.FileSystemObject")
    fso.CopyFile SourceFile, TargetFolder & Application.PathSeparator & NewFileName

    ' 確認メッセージを表示
    MsgBox "ファイルが正常にコピーされました。" & vbCrLf & "新しいファイル名: " & NewFileName, vbInformation, "完了"

End Sub

編集ファイルに仕訳作成のための列名を付与

ダイアログボックスで選択されたファイルを開き、”Bank Statement”シートをコピーして”Bank Statement（編集用）”シートに変更し、新しい列名を追加します。

Option Explicit

Sub UpdateBankStatementSheet()

    Dim ws As Worksheet
    Dim wsCopy As Worksheet
    Dim LastColumn As Long
    Dim NewColumnTitles As Variant
    Dim i As Long
    Dim OpenFileName As Variant
    Dim SourceWorkbook As Workbook

    ' ダイアログボックスでファイルを選択
    OpenFileName = Application.GetOpenFilename _
        (Title:="選択したファイルを開く", _
        FileFilter:="Excel Files *.xls* (*.xls*),")

    ' キャンセルが選択された場合、終了
    If OpenFileName = False Then
        MsgBox "ファイルが選択されませんでした。", vbExclamation, "エラー"
        Exit Sub
    End If

    ' 選択されたファイルを開く
    Set SourceWorkbook = Workbooks.Open(OpenFileName)

    ' シートを設定
    Set ws = SourceWorkbook.Worksheets("Bank Statement")

    ' シートをコピーし、新しいシート名を設定
    ws.Copy After:=ws
    Set wsCopy = ActiveSheet
    wsCopy.Name = "Bank Statement（編集用）"

    ' 最初の3行を削除
    wsCopy.Rows("1:3").Delete

    ' 最終列を取得
    LastColumn = wsCopy.Cells(1, wsCopy.Columns.Count).End(xlToLeft).Column

    ' 新しい列名を配列に設定
    NewColumnTitles = Array("為替換算", "識別フラグ", "支払日", "借方勘定", "借方補助科目", "借方消費税", "金額", "貸方勘定科目", "貸方補助科目", "貸方消費税", "金額", "摘要", "仕訳メモ")

    ' 最終列の次の列から新しい列名を設定
    For i = LBound(NewColumnTitles) To UBound(NewColumnTitles)
        wsCopy.Cells(1, LastColumn + i + 1).Value = NewColumnTitles(i)
    Next i

    ' 完了メッセージを表示
    MsgBox "Bank Statement（編集用）シートが作成されました。", vbInformation, "完了"

End Sub

入出金明細のデータを条件にして仕訳を作成する

指定された要件に従って操作を実行します。新しい列にデータを代入し、指定された条件に基づいて値を設定します。

Option Explicit

Sub UpdateNewColumns()

    Dim ws As Worksheet
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim i As Long
    Dim OpenFileName As Variant
    Dim SourceWorkbook As Workbook

    ' ダイアログボックスでファイルを選択
    OpenFileName = Application.GetOpenFilename _
        (Title:="選択したファイルを開く", _
        FileFilter:="Excel Files *.xls* (*.xls*),")

    ' キャンセルが選択された場合、終了
    If OpenFileName = False Then
        MsgBox "ファイルが選択されませんでした。", vbExclamation, "エラー"
        Exit Sub
    End If

    ' 選択されたファイルを開く
    Set SourceWorkbook = Workbooks.Open(OpenFileName)

    ' シートを設定
    Set ws = SourceWorkbook.Worksheets("Bank Statement（編集用）")

    ' 最終行と最終列を取得
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    LastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    ' F列でソート
    With ws.Sort
        .SortFields.Clear
        .SortFields.Add Key:=ws.Range("F2:F" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange ws.Range("A1:" & ws.Cells(LastRow, LastColumn).Address)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ' 新しい列にデータを代入
    For i = 2 To LastRow
        With ws
            ' F列の値を支払日に代入
            .Cells(i, LastColumn - 9).Value = .Cells(i, "F").Value

            ' I列に数値があり、R列がUSDの時、S列の数値を金額に
            If Not IsEmpty(.Cells(i, "I").Value) And .Cells(i, "R").Value = "USD" Then
                .Cells(i, "金額").Value = .Cells(i, "S").Value
            ' I列に数値があり、R列がUSDでない時、I列の金額を
            ElseIf Not IsEmpty(.Cells(i, "I").Value) And .Cells(i, "R").Value <> "USD" Then
                .Cells(i, "金額").Value = .Cells(i, "I").Value
            ' I列が空白で、R列がUSDの時、S列の数値を金額に
            ElseIf IsEmpty(.Cells(i, "I").Value) And .Cells(i, "R").Value = "USD" Then
                .Cells(i, "金額").Value = .Cells(i, "S").Value
            ' I列が空白で、R列がUSD出ない場合、H列の数値を金額に入れる
            ElseIf IsEmpty(.Cells(i, "I").Value) And .Cells(i, "R").Value <> "USD" Then
                .Cells(i, "金額").Value = .Cells(i, "H").Value
            End If
            ' 借方消費税、仕方消費税に対象外を代入
            .Cells(i, LastColumn - 3).Value = "対象外"
            .Cells(i, LastColumn + 1).Value = "対象外"

            ' J列に基づいて借方勘定科目に代入
            Select Case True
                Case InStr(1, Mid(.Cells(i, "J").Value, 2, 1), "G") > 0 Or InStr(1, Mid(.Cells(i, "J").Value, 2, 1), "A") > 0 Or InStr(1, Mid(.Cells(i, "J").Value, 2, 1), "P") > 0
                        .Cells(i, LastColumn - 4).Value = "未払金"
                Case InStr(1, .Cells(i, "J").Value, "CONSOLID") > 0
                    .Cells(i, LastColumn - 4).Value = "未払給与"
                Case InStr(1, .Cells(i, "J").Value, "EBﾃｽｳﾘｮｳ") > 0 Or InStr(1, .Cells(i, "J").Value, "TRANZACTION") > 0
                    .Cells(i, LastColumn - 4).Value = "銀行手数料"
                    .Cells(i, LastColumn - 3).Value = "課対仕入込10％"
                Case InStr(1, .Cells(i, "J").Value, "TAX") > 0
                    .Cells(i, LastColumn - 4).Value = "預り金_住民税"
                Case InStr(1, .Cells(i, "J").Value, "CUSTOMER") > 0
                    .Cells(i, LastColumn - 4).Value = "預り金_所得税"
            End Select
        

　　　　   ' J列にINTSSAが含まれている場合
            If InStr(1, .Cells(i, "J").Value, "INTSSA") > 0 Then
                ' I列に数値がある場合は、資金移動振替勘定を最終列の-9行目に代入
                If Not IsEmpty(.Cells(i, "I").Value) Then
                    .Cells(i, LastColumn - 9).Value = "資金移動振替勘定"
                ' I列に数値がない場合は、最終列の-5行目に代入
                Else
                    .Cells(i, LastColumn - 5).Value = "資金移動振替勘定"
                End If
            End If

　　　　　　' J列にREIMBURSEが含まれていて、RETURNがない場合
            If InStr(1, .Cells(i, "J").Value, "REIMBURSE") > 0 And InStr(1, .Cells(i, "J").Value, "RETURN") = 0 Then
                ' 未払金（立替精算）を最終列の-9行目に代入
                .Cells(i, LastColumn - 9).Value = "未払金（立替精算）"
            End If
            ' J列にINTDDSAが含まれている場合
            If InStr(1, .Cells(i, "J").Value, "INTDDSA") > 0 Then
                ' I列に数値がある場合は、未収入金_関連会社を最終列の-9行目に代入
                If Not IsEmpty(.Cells(i, "I").Value) Then
                    .Cells(i, LastColumn - 9).Value = "未収入金_関連会社"
                ' I列に数値がない場合は、預り金_関連会社を最終列の-5行目に代入
                Else
                    .Cells(i, LastColumn - 5).Value = "預り金_関連会社"
                End If
            End If

            ' J列にReturnが含まれている場合、組み戻し振替勘定を最終列の-9行目に代入
            If InStr(1, .Cells(i, "J").Value, "Return") > 0 Then
                .Cells(i, LastColumn - 5).Value = "組み戻し振替勘定"
            End If
　　　　　End With
    Next i
    ' 完了メッセージを表示
    MsgBox "Bank Statement（編集用）シートが更新されました。", vbInformation, "完了"

    ' 選択されたファイルを閉じる
    SourceWorkbook.Close SaveChanges:=False

End Sub

仕訳に識別フラグを立てる

最終列の-10列目の日付が上から下に連続して同じ日付であれば、複数行の伝票、連続しなければ1行の伝票として以下のルールで最終行の-11列目に入力してください。

1行の伝票データ ：2111 複数行の伝票データ 1行目 ：2110 間の行 ：2100 最終行 ：2101

Option Explicit

Sub UpdateSlipNumbers()
    Dim OpenFileName As Variant
    Dim SourceWorkbook As Workbook
    Dim ws As Worksheet
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim i As Long
    Dim currentInvoiceDate As Variant
    Dim isFirstRow As Boolean

    ' ダイアログボックスでファイルを選択
    OpenFileName = Application.GetOpenFilename _
        (Title:="選択したファイルを開く", _
        FileFilter:="Excel Files *.xls* (*.xls*),")

    ' キャンセルが選択された場合、終了
    If OpenFileName = False Then
        MsgBox "ファイルが選択されませんでした。", vbExclamation, "エラー"
        Exit Sub
    End If

    ' 選択されたファイルを開く
    Set SourceWorkbook = Workbooks.Open(OpenFileName)

    ' シートを設定
    Set ws = SourceWorkbook.Worksheets("Bank Statement（編集用）")

    ' 最終行と最終列を取得
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    LastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    ' 伝票番号の更新
    currentInvoiceDate = ws.Cells(2, LastColumn - 10).Value
    isFirstRow = True

    For i = 2 To LastRow
        With ws
            If .Cells(i, LastColumn - 10).Value <> currentInvoiceDate Then
                currentInvoiceDate = .Cells(i, LastColumn - 10).Value
                isFirstRow = True
            End If

            If isFirstRow Then
                If .Cells(i, LastColumn - 10).Value <> .Cells(i + 1, LastColumn - 10).Value Then
                    .Cells(i, LastColumn - 11).Value = "2111"
                Else
                    .Cells(i, LastColumn - 11).Value = "2110"
                End If
                isFirstRow = False
            Else
                If .Cells(i, LastColumn - 10).Value = .Cells(i + 1, LastColumn - 10).Value Then
                    .Cells(i, LastColumn - 11).Value = "2100"
                Else
                    .Cells(i, LastColumn - 11).Value = "2101"
                    isFirstRow = True
                End If
            End If
        End With
    Next i

    ' 完了メッセージを表示
    MsgBox "Bank Statement（編集用）シートの伝票番号が更新されました。", vbInformation, "完了"


End Sub

補足

Excel VBAを使用して、2022-10-12のようなテキスト形式の日付を日付型に変換する方法を以下に示します。

Sub ConvertTextToDate()
    Dim ws As Worksheet
    Dim LastRow As Long
    Dim i As Long
    Dim SourceData As String
    Dim ConvertedDate As Date

    ' シートを設定
    Set ws = ThisWorkbook.Worksheets("Bank Statement（編集用）")

    ' 最終行を取得
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' テキスト形式の日付を日付型に変換
    For i = 2 To LastRow
        ' ソースデータを取得
        SourceData = ws.Cells(i, "F").Value

        ' テキストを日付型に変換
        ConvertedDate = CDate(SourceData)

        ' 変換した日付をセルに代入
        ws.Cells(i, "F").Value = ConvertedDate
    Next i

    ' 日付形式に変換されたことを確認
    MsgBox "日付形式に変換されました。", vbInformation, "完了"
End Sub

指定された条件に従ってK列とJ列の1文字目を除いた20文字を（）で閉じた文字を最終列の-1行目に代入します。

' K列とJ列の1文字目を除いた20文字を（）で閉じた文字を最終列の-1行目に代入
            .Cells(i, LastColumn - 1).Value = .Cells(i, "K").Value & " (" & Mid(.Cells(i, "J").Value, 2, 20) & ")"

K列とJ列の15文字目から22文字目までの文字を（）で閉じた文字を最終列の-1行目に代入します。

' K列とJ列の15文字目から22文字目の文字を（）で閉じた文字を最終列の-1行目に代入
 .Cells(i, LastColumn - 1).Value = .Cells(i, "K").Value & " (" & Mid(.Cells(i, "J").Value, 15, 8) & ")"