Excel VBA 逆引き集 | 実務テンプレ完全版（超再利用部品） – 出荷レポート自動作成

Excel VBA
スポンサーリンク

ねらい：出荷明細を“整形→集計→可視化→配布”まで一括で自動化する

出荷レポートは「明細の型ブレ修正」「納期達成率・遅延件数の集計」「キャリア別・日別の基礎統計」「見える化（書式・条件付き書式）」「PDF/シート出力」の流れを一本化すると、毎日でも迷わず回せます。核は“配列I/O＋Dictionary＋正規化＋一括書き戻し”です。初心者でも貼って動くテンプレを、例題付きでかみ砕いて解説します。

共通基盤：配列I/O・正規化・数値／日付の安全変換

一括読み書きとユーティリティ

' ModShip_Base.bas
Option Explicit
Private Const SEP As String = Chr$(30)

Public Function ReadRegion(ByVal ws As Worksheet, Optional ByVal topLeft As String = "A1") As Variant
    ReadRegion = ws.Range(topLeft).CurrentRegion.Value
End Function

Public Sub WriteBlock(ByVal ws As Worksheet, ByVal a As Variant, ByVal topLeft As String)
    ws.Range(topLeft).Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub

Public Function NormKey(ByVal v As Variant) As String
    NormKey = LCase$(Trim$(CStr(v))) ' 大小無視・前後空白除去
End Function

Public Function ToNumberOrZero(ByVal v As Variant) As Double
    If IsNumeric(v) Then ToNumberOrZero = CDbl(v) Else ToNumberOrZero = 0#
End Function

Public Function ToDateOrEmpty(ByVal v As Variant) As Variant
    If IsDate(v) Then ToDateOrEmpty = CDate(v) Else ToDateOrEmpty = ""
End Function

Public Sub ApplyOutputFormat(ByVal ws As Worksheet, ByVal startAddress As String, _
                             Optional ByVal currencyCols As String = "", _
                             Optional ByVal dateCols As String = "", _
                             Optional ByVal percentCols As String = "")
    Dim rng As Range: Set rng = ws.Range(startAddress).CurrentRegion
    rng.Columns.AutoFit
    rng.Borders.LineStyle = xlContinuous
    If Len(currencyCols) > 0 Then
        Dim cc() As String: cc = Split(currencyCols, ",")
        Dim i As Long: For i = LBound(cc) To UBound(cc): ws.Columns(Trim$(cc(i))).NumberFormatLocal = "#,##0"; Next
    End If
    If Len(dateCols) > 0 Then
        Dim dc() As String: dc = Split(dateCols, ",")
        Dim j As Long: For j = LBound(dc) To UBound(dc): ws.Columns(Trim$(dc(j))).NumberFormatLocal = "yyyy-mm-dd"; Next
    End If
    If Len(percentCols) > 0 Then
        Dim pc() As String: pc = Split(percentCols, ",")
        Dim k As Long: For k = LBound(pc) To UBound(pc): ws.Columns(Trim$(pc(k))).NumberFormatLocal = "0.0%"; Next
    End If
End Sub
VB

重要ポイントの深掘り

入口で「文字数値」「テキスト日付」を必ず正すと、後段の集計や並べ替えが安定します。キーは NormKey で揺らぎを除去し、顧客やキャリアのグループ分けで漏れを防ぎます。出力書式は最終シートで一括適用し、見た目の標準化を保ちます。

明細整形：入力ゆれの補正と派生列（年月・遅延フラグ・SLA）

出荷明細のクリーニングと派生列付与

' ModShip_Clean.bas
Option Explicit

' Data: A=出荷日, B=予定納期, C=顧客ID, D=キャリア, E=出荷番号, F=箱数, G=金額
' 出力（同シート任意位置）: YearMonth, CustKey, CarrierKey, OnTimeFlag, DelayDays, SLAHit
Public Sub CleanShipmentDetail(ByVal sheetName As String, ByVal outStart As String, Optional ByVal slaDays As Long = 3)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    Dim a As Variant: a = ReadRegion(ws)

    Dim out() As Variant: ReDim out(1 To UBound(a, 1), 1 To UBound(a, 2) + 6)
    Dim lastCol As Long: lastCol = UBound(a, 2)

    ' ヘッダコピー＋追加
    Dim c As Long
    For c = 1 To lastCol: out(1, c) = a(1, c): Next
    out(1, lastCol + 1) = "YearMonth"
    out(1, lastCol + 2) = "CustKey"
    out(1, lastCol + 3) = "CarrierKey"
    out(1, lastCol + 4) = "OnTimeFlag"
    out(1, lastCol + 5) = "DelayDays"
    out(1, lastCol + 6) = "SLAHit"

    Dim r As Long
    For r = 2 To UBound(a, 1)
        For c = 1 To lastCol: out(r, c) = a(r, c): Next

        Dim shipDt As Variant: shipDt = ToDateOrEmpty(a(r, 1))
        Dim dueDt As Variant:  dueDt  = ToDateOrEmpty(a(r, 2))
        out(r, lastCol + 1) = IIf(IsDate(shipDt), Format(CDate(shipDt), "yyyy-mm"), "")

        out(r, lastCol + 2) = NormKey(a(r, 3))    ' 顧客キー
        out(r, lastCol + 3) = NormKey(a(r, 4))    ' キャリアキー

        Dim delay As Long
        If IsDate(shipDt) And IsDate(dueDt) Then
            delay = DateDiff("d", CDate(dueDt), CDate(shipDt))
            out(r, lastCol + 4) = IIf(delay <= 0, "OnTime", "Late")
            out(r, lastCol + 5) = IIf(delay > 0, delay, 0)
        Else
            out(r, lastCol + 4) = ""
            out(r, lastCol + 5) = ""
        End If

        ' 単純SLA例：出荷日から slaDays 以内に納期設定されているか（要件に合わせて変更）
        If IsDate(shipDt) And IsDate(dueDt) Then
            out(r, lastCol + 6) = IIf(DateDiff("d", CDate(shipDt), CDate(dueDt)) <= slaDays, "Hit", "Miss")
        Else
            out(r, lastCol + 6) = ""
        End If
    Next

    WriteBlock ws, out, outStart
    ApplyOutputFormat ws, outStart, "G", "A,B"
    Call ColorLateRows(ws, outStart)
End Sub

Private Sub ColorLateRows(ByVal ws As Worksheet, ByVal startAddress As String)
    With ws.Range(startAddress).CurrentRegion
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=$" & ColLetter(.Row) & "2"
        ' 補助：OnTimeFlag列の見つけ方を簡易化するなら列番号指定でもOK
    End With
End Sub

Private Function ColLetter(ByVal colIndex As Long) As String
    ColLetter = Split(Cells(1, colIndex).Address(True, False), "$")(0)
End Function
VB

重要ポイントの深掘り

出荷は「遅延判定」が命です。出荷日と予定納期から DelayDays と OnTime/Late を派生し、SLAHit のロジックを最初に合意しておくと毎日のレポートがぶれません。欠損は空で統一、日付は CDate で確定、型が崩れる入力を入口で防ぎます。

集計：日次・月次・顧客別・キャリア別・SLA達成率

日次出荷件数・遅延件数・遅延率

' ModShip_AggDaily.bas
Option Explicit

' 対象: A=出荷日, OnTimeFlag=列番号を引数で指定
Public Sub AggregateDaily(ByVal sheetName As String, ByVal outStart As String, ByVal shipDateCol As Long, ByVal flagCol As Long)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    Dim a As Variant: a = ReadRegion(ws)

    Dim cntDay As Object: Set cntDay = CreateObject("Scripting.Dictionary"): cntDay.CompareMode = 1
    Dim lateDay As Object: Set lateDay = CreateObject("Scripting.Dictionary"): lateDay.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim dt As Variant: dt = ToDateOrEmpty(a(r, shipDateCol))
        If IsDate(dt) Then
            Dim dKey As String: dKey = Format(CDate(dt), "yyyy-mm-dd")
            cntDay(dKey) = IIf(cntDay.Exists(dKey), cntDay(dKey) + 1, 1)
            If LCase$(CStr(a(r, flagCol))) = "late" Then
                lateDay(dKey) = IIf(lateDay.Exists(dKey), lateDay(dKey) + 1, 1)
            End If
        End If
    Next

    Dim out() As Variant: ReDim out(1 To cntDay.Count + 1, 1 To 4)
    out(1, 1) = "Date": out(1, 2) = "ShipCount": out(1, 3) = "LateCount": out(1, 4) = "LateRate"

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In cntDay.Keys
        Dim total As Long: total = cntDay(k)
        Dim late As Long: late = IIf(lateDay.Exists(k), lateDay(k), 0)
        out(i, 1) = k
        out(i, 2) = total
        out(i, 3) = late
        out(i, 4) = IIf(total > 0, late / total, 0#)
        i = i + 1
    Next

    WriteBlock ws, out, outStart
    ApplyOutputFormat ws, outStart, "", "A", "D"
End Sub
VB

月次合計・遅延率・金額合計

' ModShip_AggMonthly.bas
Option Explicit

' A=出荷日, G=金額, OnTimeFlag列番号引数
Public Sub AggregateMonthly(ByVal sheetName As String, ByVal outStart As String, ByVal shipDateCol As Long, ByVal amountCol As Long, ByVal flagCol As Long)
    Dim a As Variant: a = ReadRegion(Worksheets(sheetName))
    Dim cntMon As Object: Set cntMon = CreateObject("Scripting.Dictionary"): cntMon.CompareMode = 1
    Dim lateMon As Object: Set lateMon = CreateObject("Scripting.Dictionary"): lateMon.CompareMode = 1
    Dim sumMon As Object: Set sumMon = CreateObject("Scripting.Dictionary"): sumMon.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim dt As Variant: dt = ToDateOrEmpty(a(r, shipDateCol))
        If IsDate(dt) Then
            Dim mKey As String: mKey = Format(CDate(dt), "yyyy-mm")
            cntMon(mKey) = IIf(cntMon.Exists(mKey), cntMon(mKey) + 1, 1)
            If LCase$(CStr(a(r, flagCol))) = "late" Then
                lateMon(mKey) = IIf(lateMon.Exists(mKey), lateMon(mKey) + 1, 1)
            End If
            Dim amt As Double: amt = ToNumberOrZero(a(r, amountCol))
            sumMon(mKey) = IIf(sumMon.Exists(mKey), sumMon(mKey) + amt, amt)
        End If
    Next

    Dim out() As Variant: ReDim out(1 To cntMon.Count + 1, 1 To 5)
    out(1, 1) = "Month": out(1, 2) = "ShipCount": out(1, 3) = "LateCount": out(1, 4) = "LateRate": out(1, 5) = "SumAmount"

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In cntMon.Keys
        Dim total As Long: total = cntMon(k)
        Dim late As Long: late = IIf(lateMon.Exists(k), lateMon(k), 0)
        out(i, 1) = k
        out(i, 2) = total
        out(i, 3) = late
        out(i, 4) = IIf(total > 0, late / total, 0#)
        out(i, 5) = IIf(sumMon.Exists(k), sumMon(k), 0#)
        i = i + 1
    Next

    WriteBlock Worksheets(sheetName), out, outStart
    ApplyOutputFormat Worksheets(sheetName), outStart, "E", "", "D"
End Sub
VB

顧客別・キャリア別の出荷件数／遅延率

' ModShip_AggBreakdown.bas
Option Explicit

' 顧客・キャリア単位の件数と遅延率
Public Sub AggregateByCustomerCarrier(ByVal sheetName As String, ByVal outStart As String, ByVal custKeyCol As Long, ByVal carrierKeyCol As Long, ByVal flagCol As Long)
    Dim a As Variant: a = ReadRegion(Worksheets(sheetName))
    Dim cnt As Object: Set cnt = CreateObject("Scripting.Dictionary"): cnt.CompareMode = 1
    Dim late As Object: Set late = CreateObject("Scripting.Dictionary"): late.CompareMode = 1

    Dim r As Long
    For r = 2 To UBound(a, 1)
        Dim k As String: k = NormKey(a(r, custKeyCol)) & SEP & NormKey(a(r, carrierKeyCol))
        cnt(k) = IIf(cnt.Exists(k), cnt(k) + 1, 1)
        If LCase$(CStr(a(r, flagCol))) = "late" Then
            late(k) = IIf(late.Exists(k), late(k) + 1, 1)
        End If
    Next

    Dim out() As Variant: ReDim out(1 To cnt.Count + 1, 1 To 4)
    out(1, 1) = "Customer|Carrier": out(1, 2) = "ShipCount": out(1, 3) = "LateCount": out(1, 4) = "LateRate"

    Dim i As Long: i = 2
    Dim k As Variant
    For Each k In cnt.Keys
        Dim total As Long: total = cnt(k)
        Dim lateCnt As Long: lateCnt = IIf(late.Exists(k), late(k), 0)
        out(i, 1) = k
        out(i, 2) = total
        out(i, 3) = lateCnt
        out(i, 4) = IIf(total > 0, lateCnt / total, 0#)
        i = i + 1
    Next

    WriteBlock Worksheets(sheetName), out, outStart
    ApplyOutputFormat Worksheets(sheetName), outStart, "", "", "D"
End Sub
VB

重要ポイントの深掘り

遅延率は「遅延件数/総件数」で小数として持ち、表示はパーセント書式で統一します。顧客×キャリアの複合キーは安全な区切りで作り、誤結合を防ぎます。欠損はゼロや空で揃え、後段のグラフや並べ替えが崩れないようにします。

見える化と配布：条件付き書式・チャート・PDF出力

遅延行の強調とサマリ色分け

' ModShip_View.bas
Option Explicit

Public Sub HighlightLate(ByVal sheetName As String, ByVal startAddress As String, ByVal flagCol As Long)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    With ws.Range(startAddress).CurrentRegion
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:="=$" & ColumnLetter(flagCol) & "2=""Late"""
        .FormatConditions(1).Interior.Color = RGB(255, 220, 220)
    End With
End Sub

Private Function ColumnLetter(ByVal col As Long) As String
    ColumnLetter = Split(Cells(1, col).Address(True, False), "$")(0)
End Function
VB

月次サマリからグラフ作成

' 月次サマリ（Month, ShipCount, LateRate, SumAmount）から折れ線＋棒グラフを作る
Public Sub CreateMonthlyChart(ByVal sheetName As String, ByVal startAddress As String)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    Dim rng As Range: Set rng = ws.Range(startAddress).CurrentRegion
    Dim ch As ChartObject: Set ch = ws.ChartObjects.Add(Left:=rng.Left, Top:=rng.Top + rng.Height + 10, Width:=500, Height:=300)
    With ch.Chart
        .ChartType = xlColumnClustered
        .SetSourceData Source:=rng.Columns("A:B")
        Dim sLate As Series: Set sLate = .SeriesCollection.NewSeries
        sLate.Values = rng.Columns("D")
        sLate.XValues = rng.Columns("A")
        sLate.ChartType = xlLine
        sLate.AxisGroup = 2
        .HasTitle = True
        .ChartTitle.Text = "Monthly Shipments & Late Rate"
    End With
End Sub
VB

PDF出力（レポート配布用）

' レンジをPDFにエクスポート
Public Sub ExportReportPdf(ByVal sheetName As String, ByVal startAddress As String, ByVal pdfPath As String)
    Dim ws As Worksheet: Set ws = Worksheets(sheetName)
    Dim rng As Range: Set rng = ws.Range(startAddress).CurrentRegion
    ws.PageSetup.Orientation = xlLandscape
    ws.PageSetup.Zoom = False
    ws.PageSetup.FitToPagesTall = 1
    ws.PageSetup.FitToPagesWide = 1
    rng.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath, Quality:=xlQualityStandard, OpenAfterPublish:=False
End Sub
VB

重要ポイントの深掘り

色分けは「一目で遅延が分かる」ことが目的。チャートは件数と遅延率を重ね、傾向が見える構成にします。PDFは印刷設定を調整して“1ページに収める”が基本。配布の導線を標準化すると、レポートが毎日ストレスなく出せます。

例題の通し方：整形→日次・月次集計→顧客×キャリア→グラフ→PDF

パイプライン実行例

' ModShip_Example.bas
Option Explicit

Public Sub Run_ShipmentReport()
    ' 1) 明細整形（YearMonth/Keys/遅延派生/SLA）
    CleanShipmentDetail "Shipment", "Z1", 3

    ' 2) 日次集計（出荷日=A=1列目、OnTimeFlagは整形追加列=Z1からの相対を適宜確認）
    AggregateDaily "Shipment", "AA1", 1, 10 ' 例：10列目がOnTimeFlagなら置き換え

    ' 3) 月次集計（出荷日=A=1、金額=G=7、OnTimeFlag=10）
    AggregateMonthly "Shipment", "AC1", 1, 7, 10

    ' 4) 顧客×キャリア集計（CustKey=追加列、CarrierKey=追加列、OnTimeFlag=10）
    AggregateByCustomerCarrier "Shipment", "AE1", 9, 10, 10 ' 列番号は環境に合わせて

    ' 5) 見える化（遅延強調・チャート）
    HighlightLate "Shipment", "Z1", 10
    CreateMonthlyChart "Shipment", "AC1"

    ' 6) PDF出力
    ExportReportPdf "Shipment", "AC1", ThisWorkbook.Path & "\Shipment_Monthly.pdf"

    MsgBox "出荷レポートの自動作成が完了しました。", vbInformation
End Sub
VB

期待動作の確認ポイント

整形後に遅延・SLAが正しく判定され、日次・月次・顧客×キャリアの集計がヘッダ付きで出力されます。遅延行は薄赤で強調、月次グラフが作成され、PDFも出力されます。列番号は実データの構成に合わせて引数を調整してください。

落とし穴と対策（深掘り）

テキスト日付・文字数値で壊れる

入口で ToDateOrEmpty／ToNumberOrZero を通し、ダメなら安全値（空・0）に落とします。並べ替え・合算・率計算の安定化に直結します。

遅延定義・SLAの曖昧さ

DateDiff の定義（日付の切り上げ/切り捨て、土日除外の扱い）を先に決めます。必要なら営業日計算へ拡張して運用に合わせます。

列変更でコードが壊れる

列番号（引数）と出力開始セルを運用で固定。追加列は“派生列”として一括生成し、後段はその列を参照する設計に。

セル逐次書きで遅い・固まる

配列で結果を作り、一括書き戻し。10万行でもUIが安定し、毎日のバッチが安心して回ります。

まとめ：整形→集計→見える化→配布の一本化で、出荷レポートを強くする

出荷明細を入口で正し、遅延・SLAを明確に定義し、日次・月次・顧客×キャリアの粒度で集計。書式・グラフ・PDFまで自動化すると、毎日のレポートが“同じ品質で速く”出せます。

スポンサーリンク
タイトルとURLをコピーしました