Excel VBA | 実務ですぐ使える「改良版テンプレート（VBA 標準構成テンプレ）」

VBA

2010.12.302025.11.19

完全サンプル構成（シート＋VBAモジュール）
シート構成
VBA モジュール構成（9 モジュール）
VBA コード例（主要部分）

完全サンプル構成（シート＋VBAモジュール）

ここからは、完全版 Excel VBA サンプルファイル を設計します。
ポイントは以下の通りです：

シート構成

入力 – CSV読込データ格納用
出力 – 加工後データ書き出し用
ログ – 実行ログ（日時・内容）
設定 – パラメータ管理（DB接続文字列、CSVフォルダ、メール件名など）

VBA モジュール構成（9 モジュール）

モジュール	内容
M_Main	メイン処理の呼び出し、エラー処理統合
M_Common	共通関数：Nz、ToHankaku、設定取得など
M_Log	ログ書込み・ログローテーション
M_ErrorHandler	エラー統合処理
M_Business	業務処理（CSV読み込み、配列処理、出力）
M_FileIO	CSV読み込み、フォルダ一括処理
M_DB	ADO接続・SQL実行
M_Outlook	Outlookメール送信
M_Progress	UserFormで進捗バー表示

VBA コード例（主要部分）

① M_Main

Option Explicit

Sub RunMain()
    On Error GoTo ERR_HANDLER
    LogWrite "=== 処理開始 ==="
    
    Call BusinessMain
    
    LogWrite "=== 処理終了 ==="
    MsgBox "完了しました", vbInformation
    Exit Sub

ERR_HANDLER:
    HandleError "RunMain", Err.Number, Err.Description
End Sub

Option Explicit

Sub RunMain()
    On Error GoTo ERR_HANDLER
    LogWrite "=== 処理開始 ==="
    
    Call BusinessMain
    
    LogWrite "=== 処理終了 ==="
    MsgBox "完了しました", vbInformation
    Exit Sub

ERR_HANDLER:
    HandleError "RunMain", Err.Number, Err.Description
End Sub

M_Common

Option Explicit

Function Nz(v, Optional defaultValue As Variant = "") As Variant
    If IsEmpty(v) Or IsNull(v) Or v = "" Then
        Nz = defaultValue
    Else
        Nz = v
    End If
End Function

Function ToHankaku(s As String) As String
    ToHankaku = StrConv(s, vbNarrow)
End Function

Function GetConfig(key As String) As String
    Dim sh As Worksheet
    Set sh = Sheets("設定")
    Dim rng As Range
    Set rng = sh.Range("A:A").Find(what:=key, LookAt:=xlWhole)
    If rng Is Nothing Then
        GetConfig = ""
    Else
        GetConfig = rng.Offset(0, 1).Value
    End If
End Function

Option Explicit

Function Nz(v, Optional defaultValue As Variant = "") As Variant
    If IsEmpty(v) Or IsNull(v) Or v = "" Then
        Nz = defaultValue
    Else
        Nz = v
    End If
End Function

Function ToHankaku(s As String) As String
    ToHankaku = StrConv(s, vbNarrow)
End Function

Function GetConfig(key As String) As String
    Dim sh As Worksheet
    Set sh = Sheets("設定")
    Dim rng As Range
    Set rng = sh.Range("A:A").Find(what:=key, LookAt:=xlWhole)
    If rng Is Nothing Then
        GetConfig = ""
    Else
        GetConfig = rng.Offset(0, 1).Value
    End If
End Function

M_Log

Option Explicit

Sub LogWrite(msg As String)
    Dim sh As Worksheet
    Set sh = Sheets("ログ")
    
    ' ログローテーション: 1000行超えたら削除
    If sh.Cells(Rows.Count, 1).End(xlUp).Row > 1000 Then
        sh.Rows("2:2").Delete
    End If

    Dim r As Long
    r = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
    sh.Cells(r, 1).Value = Now
    sh.Cells(r, 2).Value = msg
End Sub

Option Explicit

Sub LogWrite(msg As String)
    Dim sh As Worksheet
    Set sh = Sheets("ログ")
    
    ' ログローテーション: 1000行超えたら削除
    If sh.Cells(Rows.Count, 1).End(xlUp).Row > 1000 Then
        sh.Rows("2:2").Delete
    End If

    Dim r As Long
    r = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
    sh.Cells(r, 1).Value = Now
    sh.Cells(r, 2).Value = msg
End Sub

M_ErrorHandler

Option Explicit

Sub HandleError(procName As String, errNum As Long, errMsg As String)
    LogWrite "【エラー】" & procName & " / Err:" & errNum & " / " & errMsg
    MsgBox "エラーが発生しました：" & vbCrLf & _
           "場所：" & procName & vbCrLf & _
           "内容：" & errMsg, vbCritical
End Sub

Option Explicit

Sub HandleError(procName As String, errNum As Long, errMsg As String)
    LogWrite "【エラー】" & procName & " / Err:" & errNum & " / " & errMsg
    MsgBox "エラーが発生しました：" & vbCrLf & _
           "場所：" & procName & vbCrLf & _
           "内容：" & errMsg, vbCritical
End Sub

M_Business

Option Explicit

Sub BusinessMain()
    On Error GoTo ERR_HANDLER
    LogWrite "業務処理開始"

    ' CSV読み込み
    Dim csvPath As String
    csvPath = GetConfig("CSV_FOLDER") & "\sample.csv"
    Dim data As Variant
    data = ReadCSV(csvPath)
    
    ' データ正規化
    data = NormalizeData(data)
    
    ' 出力
    WriteData data
    
    LogWrite "業務処理終了"
    Exit Sub

ERR_HANDLER:
    HandleError "BusinessMain", Err.Number, Err.Description
End Sub

Function NormalizeData(arr As Variant) As Variant
    Dim r As Long, c As Long
    For r = 1 To UBound(arr, 1)
        For c = 1 To UBound(arr, 2)
            arr(r, c) = ToHankaku(Trim(arr(r, c)))
        Next c
    Next r
    NormalizeData = arr
End Function

Sub WriteData(arr As Variant)
    Dim sh As Worksheet
    Set sh = Sheets("出力")
    sh.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

Option Explicit

Sub BusinessMain()
    On Error GoTo ERR_HANDLER
    LogWrite "業務処理開始"

    ' CSV読み込み
    Dim csvPath As String
    csvPath = GetConfig("CSV_FOLDER") & "\sample.csv"
    Dim data As Variant
    data = ReadCSV(csvPath)
    
    ' データ正規化
    data = NormalizeData(data)
    
    ' 出力
    WriteData data
    
    LogWrite "業務処理終了"
    Exit Sub

ERR_HANDLER:
    HandleError "BusinessMain", Err.Number, Err.Description
End Sub

Function NormalizeData(arr As Variant) As Variant
    Dim r As Long, c As Long
    For r = 1 To UBound(arr, 1)
        For c = 1 To UBound(arr, 2)
            arr(r, c) = ToHankaku(Trim(arr(r, c)))
        Next c
    Next r
    NormalizeData = arr
End Function

Sub WriteData(arr As Variant)
    Dim sh As Worksheet
    Set sh = Sheets("出力")
    sh.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

M_FileIO（CSV / フォルダ処理）

Function ReadCSV(path As String) As Variant
    Dim f As Integer, line As String
    Dim arr() As Variant, tmp() As String
    Dim i As Long: i = 0

    If Dir(path) = "" Then Exit Function
    f = FreeFile
    Open path For Input As #f
    Do Until EOF(f)
        Line Input #f, line
        tmp = Split(line, ",")
        ReDim Preserve arr(0 To i, 0 To UBound(tmp))
        Dim j As Long
        For j = 0 To UBound(tmp)
            arr(i, j) = tmp(j)
        Next j
        i = i + 1
    Loop
    Close #f
    ReadCSV = arr
End Function

Sub ProcessFolder(folderPath As String)
    Dim fName As String
    fName = Dir(folderPath & "\*.xlsx")
    Do While fName <> ""
        Workbooks.Open folderPath & "\" & fName
        LogWrite "Opened: " & fName
        ' 業務処理呼び出し
        Workbooks(fName).Close SaveChanges:=True
        fName = Dir()
    Loop
End Sub

Function ReadCSV(path As String) As Variant
    Dim f As Integer, line As String
    Dim arr() As Variant, tmp() As String
    Dim i As Long: i = 0

    If Dir(path) = "" Then Exit Function
    f = FreeFile
    Open path For Input As #f
    Do Until EOF(f)
        Line Input #f, line
        tmp = Split(line, ",")
        ReDim Preserve arr(0 To i, 0 To UBound(tmp))
        Dim j As Long
        For j = 0 To UBound(tmp)
            arr(i, j) = tmp(j)
        Next j
        i = i + 1
    Loop
    Close #f
    ReadCSV = arr
End Function

Sub ProcessFolder(folderPath As String)
    Dim fName As String
    fName = Dir(folderPath & "\*.xlsx")
    Do While fName <> ""
        Workbooks.Open folderPath & "\" & fName
        LogWrite "Opened: " & fName
        ' 業務処理呼び出し
        Workbooks(fName).Close SaveChanges:=True
        fName = Dir()
    Loop
End Sub

M_DB（ADO接続）

Function GetDBData(connStr As String, sql As String) As Variant
    Dim cn As Object, rs As Object
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    cn.Open connStr
    rs.Open sql, cn
    GetDBData = rs.GetRows
    rs.Close
    cn.Close
End Function

Function GetDBData(connStr As String, sql As String) As Variant
    Dim cn As Object, rs As Object
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    cn.Open connStr
    rs.Open sql, cn
    GetDBData = rs.GetRows
    rs.Close
    cn.Close
End Function

M_Outlook

Sub SendMail(toAddr As String, subject As String, body As String)
    Dim olApp As Object, olMail As Object
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    
    With olMail
        .To = toAddr
        .Subject = subject
        .Body = body
        .Send
    End With
    LogWrite "Mail sent to " & toAddr
End Sub

Sub SendMail(toAddr As String, subject As String, body As String)
    Dim olApp As Object, olMail As Object
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)
    
    With olMail
        .To = toAddr
        .Subject = subject
        .Body = body
        .Send
    End With
    LogWrite "Mail sent to " & toAddr
End Sub

M_Progress（UserForm）

UserForm1 に Frame1 + Label1 を用意
Label1.Width を変化させることで進捗表示

Sub ShowProgress(total As Long)
    Dim frm As UserForm1
    Set frm = New UserForm1
    frm.Label1.Width = 0
    frm.Show vbModeless
    
    Dim i As Long
    For i = 1 To total
        frm.Label1.Width = i / total * frm.Frame1.Width
        DoEvents
    Next i
    
    Unload frm
End Sub

Sub ShowProgress(total As Long)
    Dim frm As UserForm1
    Set frm = New UserForm1
    frm.Label1.Width = 0
    frm.Show vbModeless
    
    Dim i As Long
    For i = 1 To total
        frm.Label1.Width = i / total * frm.Frame1.Width
        DoEvents
    Next i
    
    Unload frm
End Sub