Excel VBA 逆引き集 | CSVとの差分

Excel VBA
スポンサーリンク

CSVとの差分

「CSVと既存のExcel表の差分を取りたい」「2つのCSVを比較して“新規・削除・変更”を出したい」——初心者でも壊れず速く動くテンプレをまとめました。コツは、CSVを一時シートに読み込んで配列で比較、キーを正規化、結果は一括で出力すること。

導入と基本方針

  • 対象シナリオ:
    • CSV→Excel: CSV（外部）と既存のマスタ表（Excel）との差分。
    • CSV↔CSV: 2つのCSVファイルを直接比較。
  • 3分類の定義:
    • 新規: CSV側にあってExcel側（または旧CSV）にない。
    • 削除: Excel側（または旧CSV）にあってCSV側にない。
    • 変更: 両側にキーはあるが、項目値が違う。
  • 安全設計:
    • キー正規化: Trim＋UCaseで表記揺れを吸収。
    • 見出し名で列特定: 列順変更に強くする。
    • 配列＋辞書: セル往復ゼロで高速。
    • 一括貼り付け: 出力は配列をまとめて貼り付け。

共通ユーティリティ（速度・正規化・見出し）

Option Explicit

Private Sub SpeedOn()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
End Sub

Private Sub SpeedOff()
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Function EnsureSheet(ByVal name As String, Optional ByVal clear As Boolean = True) As Worksheet
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(name)
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        ws.Name = name
    End If
    If clear Then ws.Cells.Clear
    Set EnsureSheet = ws
End Function

Private Function FindHeader(ByVal headerRow As Range, ByVal name As String) As Long
    Dim hit As Range
    Set hit = headerRow.Find(What:=name, LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
    FindHeader = IIf(hit Is Nothing, 0, hit.Column)
End Function

Private Function NormKey(ByVal v As Variant) As String
    NormKey = UCase$(Trim$(CStr(v)))
End Function
VB
  • 速度最適化: 画面更新・イベント・自動計算を止めてから処理し、最後に戻す。
  • 安全な出力先: EnsureSheetで何度でも安全に出力シートを用意。
  • キー正規化: Trim＋UCaseで“同じなのに違う”ミスを防止。
  • 見出し取得: FindHeaderで列順変動への耐性を持たせる。

CSV読み込みテンプレ（一時シートへ取り込み）

CSVを別ブックで開かず、現在ブックの一時シートに読み込んで配列化します。

Private Function LoadCsvToArray(ByVal csvPath As String, Optional ByVal sheetName As String = "CSV_TMP") As Variant
    Dim ws As Worksheet: Set ws = EnsureSheet(sheetName, True)
    ' QueryTablesを使うと改行・区切り・文字コードの扱いが安定しやすい
    With ws.QueryTables.Add(Connection:="TEXT;" & csvPath, Destination:=ws.Range("A1"))
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileCommaDelimiter = True
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileOtherDelimiter = False
        .TextFileConsecutiveDelimiter = False
        .TextFilePlatform = 65001      'UTF-8想定。Shift-JISなら932
        .TextFileColumnDataTypes = Array(1) '全部テキスト読みで型ブレ回避、後で数値化
        .AdjustColumnWidth = True
        .Refresh BackgroundQuery:=False
    End With
    LoadCsvToArray = ws.Range("A1").CurrentRegion.Value
End Function
VB
  • 文字コード: UTF-8なら65001、Shift-JISなら932に変更。
  • 区切り: 一般的なCSVはカンマ。必要ならセミコロン等に切り替え。
  • 型ブレ対策: まず文字として取り込み、比較時に数値化。

CSV→Excelの差分（新規／削除／変更）自動出力

既存のExcel表（シートA）とCSV（最新）を比較し、3シートに差分を出します。キーは見出し名で指定します。

Sub Diff_Csv_To_Excel()
    SpeedOn

    '1) CSVファイルの選択
    Dim f As FileDialog: Set f = Application.FileDialog(msoFileDialogFilePicker)
    With f
        .AllowMultiSelect = False
        .Title = "CSVファイルを選択"
        .Filters.Clear
        .Filters.Add "CSV", "*.csv"
        If .Show <> -1 Then SpeedOff: Exit Sub
    End With
    Dim csvPath As String: csvPath = f.SelectedItems(1)

    '2) データ取得
    Dim vA As Variant: vA = Worksheets("A").Range("A1").CurrentRegion.Value
    Dim vC As Variant: vC = LoadCsvToArray(csvPath, "CSV_TMP")

    '3) 見出し設定（キーと比較項目）
    Dim rgA As Range: Set rgA = Worksheets("A").Range("A1").CurrentRegion
    Dim rgC As Range: Set rgC = Worksheets("CSV_TMP").Range("A1").CurrentRegion

    Dim keyHeader As String: keyHeader = "コード"
    Dim cKeyA As Long: cKeyA = FindHeader(rgA.Rows(1), keyHeader)
    Dim cKeyC As Long: cKeyC = FindHeader(rgC.Rows(1), keyHeader)
    If cKeyA = 0 Or cKeyC = 0 Then SpeedOff: MsgBox "キー見出し（コード）が見つかりません": Exit Sub

    '比較項目（必要に応じて増減）
    Dim fields As Variant: fields = Array("名称", "単価", "カテゴリ", "在庫")
    Dim i As Long
    Dim mapA() As Long: ReDim mapA(LBound(fields) To UBound(fields))
    Dim mapC() As Long: ReDim mapC(LBound(fields) To UBound(fields))
    For i = LBound(fields) To UBound(fields)
        mapA(i) = FindHeader(rgA.Rows(1), fields(i))
        mapC(i) = FindHeader(rgC.Rows(1), fields(i))
        If mapA(i) = 0 Or mapC(i) = 0 Then SpeedOff: MsgBox "見出し不足：" & fields(i): Exit Sub
    Next

    '4) CSV辞書（キー→行）
    Dim dC As Object: Set dC = CreateObject("Scripting.Dictionary")
    Dim r As Long, k As String
    For r = 2 To UBound(vC, 1)
        k = NormKey(vC(r, cKeyC))
        If Len(k) > 0 Then dC(k) = r
    Next

    '5) 出力シート
    Dim wsNew As Worksheet: Set wsNew = EnsureSheet("新規(CSVのみ)", True)
    Dim wsDel As Worksheet: Set wsDel = EnsureSheet("削除(Excelのみ)", True)
    Dim wsChg As Worksheet: Set wsChg = EnsureSheet("変更(項目差分)", True)
    wsNew.Range("A1:D1").Value = Array("コード", "名称(CSV)", "単価(CSV)", "備考")
    wsDel.Range("A1:D1").Value = Array("コード", "名称(Excel)", "単価(Excel)", "備考")
    wsChg.Range("A1:E1").Value = Array("コード", "項目", "Excel値", "CSV値", "差分(数値のみ)")

    Dim rNew As Long: rNew = 2
    Dim rDel As Long: rDel = 2
    Dim rChg As Long: rChg = 2

    '6) Excel側ループ：削除・変更
    Dim setA As Object: Set setA = CreateObject("Scripting.Dictionary")
    For r = 2 To UBound(vA, 1)
        k = NormKey(vA(r, cKeyA))
        If Len(k) = 0 Then GoTo contA
        setA(k) = True

        If dC.Exists(k) Then
            Dim rc As Long: rc = dC(k)
            For i = LBound(fields) To UBound(fields)
                Dim va As Variant: va = vA(r, mapA(i))
                Dim vc As Variant: vc = vC(rc, mapC(i))
                Dim isNum As Boolean: isNum = (fields(i) Like "*単価*" Or fields(i) Like "*金額*" Or fields(i) Like "*在庫*")
                Dim diff As Boolean
                If isNum Then
                    diff = (CDbl(Val(va)) <> CDbl(Val(vc)))
                ElseIf IsDate(va) Or IsDate(vc) Then
                    diff = (Format$(CDate(va), "yyyy-mm-dd") <> Format$(CDate(vc), "yyyy-mm-dd"))
                Else
                    diff = (CStr(va) <> CStr(vc))
                End If
                If diff Then
                    wsChg.Cells(rChg, 1).Value = vA(r, cKeyA)
                    wsChg.Cells(rChg, 2).Value = fields(i)
                    wsChg.Cells(rChg, 3).Value = va
                    wsChg.Cells(rChg, 4).Value = vc
                    wsChg.Cells(rChg, 5).Value = IIf(isNum, CDbl(Val(vc)) - CDbl(Val(va)), "")
                    rChg = rChg + 1
                End If
            Next
        Else
            wsDel.Cells(rDel, 1).Value = vA(r, cKeyA)
            '名称・単価が無い場合は適宜変更
            wsDel.Cells(rDel, 2).Value = vA(r, FindHeader(rgA.Rows(1), "名称"))
            wsDel.Cells(rDel, 3).Value = vA(r, FindHeader(rgA.Rows(1), "単価"))
            wsDel.Cells(rDel, 4).Value = "Excelのみ"
            rDel = rDel + 1
        End If
contA:
    Next

    '7) CSVのみ（新規）
    Dim rr As Long
    For rr = 2 To UBound(vC, 1)
        k = NormKey(vC(rr, cKeyC))
        If Len(k) > 0 And Not setA.Exists(k) Then
            wsNew.Cells(rNew, 1).Value = vC(rr, cKeyC)
            wsNew.Cells(rNew, 2).Value = vC(rr, FindHeader(rgC.Rows(1), "名称"))
            wsNew.Cells(rNew, 3).Value = vC(rr, FindHeader(rgC.Rows(1), "単価"))
            wsNew.Cells(rNew, 4).Value = "CSVのみ"
            rNew = rNew + 1
        End If
    Next

    '8) 整形
    Dim arrWs As Variant: arrWs = Array(wsNew, wsDel, wsChg)
    Dim x As Variant
    For Each x In arrWs
        x.Rows(1).Font.Bold = True
        x.Columns.AutoFit
    Next

    SpeedOff
    MsgBox "新規:" & rNew - 2 & " / 削除:" & rDel - 2 & " / 変更:" & rChg - 2
End Sub
VB
  • ポイント
    • ファイルダイアログ: CSVファイルを選べばそのまま比較。
    • 数値・日付の型統一: Val→CDblとFormat("yyyy-mm-dd")で誤判定防止。
    • 3シート出力: 新規/削除/変更が一目で分かる。

2つのCSVの差分（ファイル選択→3分類）

CSV同士を直接比較したいときの最短テンプレです。

Sub Diff_TwoCsvs()
    SpeedOn

    'ファイル選択（旧→新）
    Dim f As FileDialog: Set f = Application.FileDialog(msoFileDialogFilePicker)
    Dim ok As Boolean
    f.AllowMultiSelect = False: f.Filters.Clear: f.Filters.Add "CSV", "*.csv"
    f.Title = "旧CSVを選択": ok = (f.Show = -1): If Not ok Then SpeedOff: Exit Sub
    Dim oldCsv As String: oldCsv = f.SelectedItems(1)

    f.Title = "新CSVを選択": ok = (f.Show = -1): If Not ok Then SpeedOff: Exit Sub
    Dim newCsv As String: newCsv = f.SelectedItems(1)

    '読み込み
    Dim vOld As Variant: vOld = LoadCsvToArray(oldCsv, "CSV_OLD")
    Dim vNew As Variant: vNew = LoadCsvToArray(newCsv, "CSV_NEW")
    Dim rgO As Range: Set rgO = Worksheets("CSV_OLD").Range("A1").CurrentRegion
    Dim rgN As Range: Set rgN = Worksheets("CSV_NEW").Range("A1").CurrentRegion

    'キーと比較項目（見出し名必須）
    Dim keyHeader As String: keyHeader = "コード"
    Dim cKeyO As Long: cKeyO = FindHeader(rgO.Rows(1), keyHeader)
    Dim cKeyN As Long: cKeyN = FindHeader(rgN.Rows(1), keyHeader)
    If cKeyO = 0 Or cKeyN = 0 Then SpeedOff: MsgBox "キー見出し（コード）が見つかりません": Exit Sub

    Dim fields As Variant: fields = Array("名称", "単価", "カテゴリ", "在庫")
    Dim i As Long
    Dim mapO() As Long: ReDim mapO(LBound(fields) To UBound(fields))
    Dim mapN() As Long: ReDim mapN(LBound(fields) To UBound(fields))
    For i = LBound(fields) To UBound(fields)
        mapO(i) = FindHeader(rgO.Rows(1), fields(i))
        mapN(i) = FindHeader(rgN.Rows(1), fields(i))
        If mapO(i) = 0 Or mapN(i) = 0 Then SpeedOff: MsgBox "見出し不足：" & fields(i): Exit Sub
    Next

    '辞書化（新CSV）
    Dim dN As Object: Set dN = CreateObject("Scripting.Dictionary")
    Dim r As Long, k As String
    For r = 2 To UBound(vNew, 1)
        k = NormKey(vNew(r, cKeyN))
        If Len(k) > 0 Then dN(k) = r
    Next

    '出力
    Dim wsNew As Worksheet: Set wsNew = EnsureSheet("新規(新CSVのみ)", True)
    Dim wsDel As Worksheet: Set wsDel = EnsureSheet("削除(旧CSVのみ)", True)
    Dim wsChg As Worksheet: Set wsChg = EnsureSheet("変更(CSV差分)", True)
    wsNew.Range("A1:D1").Value = Array("コード", "名称(新)", "単価(新)", "備考")
    wsDel.Range("A1:D1").Value = Array("コード", "名称(旧)", "単価(旧)", "備考")
    wsChg.Range("A1:E1").Value = Array("コード", "項目", "旧CSV", "新CSV", "差分")

    Dim rNew As Long: rNew = 2
    Dim rDel As Long: rDel = 2
    Dim rChg As Long: rChg = 2

    '旧CSVループ：削除・変更
    Dim setOld As Object: Set setOld = CreateObject("Scripting.Dictionary")
    For r = 2 To UBound(vOld, 1)
        k = NormKey(vOld(r, cKeyO))
        If Len(k) = 0 Then GoTo contO
        setOld(k) = True

        If dN.Exists(k) Then
            Dim rn As Long: rn = dN(k)
            For i = LBound(fields) To UBound(fields)
                Dim vo As Variant: vo = vOld(r, mapO(i))
                Dim vn As Variant: vn = vNew(rn, mapN(i))
                Dim isNum As Boolean: isNum = (fields(i) Like "*単価*" Or fields(i) Like "*金額*" Or fields(i) Like "*在庫*")
                Dim diff As Boolean
                If isNum Then
                    diff = (CDbl(Val(vo)) <> CDbl(Val(vn)))
                ElseIf IsDate(vo) Or IsDate(vn) Then
                    diff = (Format$(CDate(vo), "yyyy-mm-dd") <> Format$(CDate(vn), "yyyy-mm-dd"))
                Else
                    diff = (CStr(vo) <> CStr(vn))
                End If
                If diff Then
                    wsChg.Cells(rChg, 1).Value = vOld(r, cKeyO)
                    wsChg.Cells(rChg, 2).Value = fields(i)
                    wsChg.Cells(rChg, 3).Value = vo
                    wsChg.Cells(rChg, 4).Value = vn
                    wsChg.Cells(rChg, 5).Value = IIf(isNum, CDbl(Val(vn)) - CDbl(Val(vo)), "")
                    rChg = rChg + 1
                End If
            Next
        Else
            wsDel.Cells(rDel, 1).Value = vOld(r, cKeyO)
            wsDel.Cells(rDel, 2).Value = vOld(r, FindHeader(rgO.Rows(1), "名称"))
            wsDel.Cells(rDel, 3).Value = vOld(r, FindHeader(rgO.Rows(1), "単価"))
            wsDel.Cells(rDel, 4).Value = "旧のみ"
            rDel = rDel + 1
        End If
contO:
    Next

    '新CSVのみ（新規）
    Dim rn As Long
    For rn = 2 To UBound(vNew, 1)
        k = NormKey(vNew(rn, cKeyN))
        If Len(k) > 0 And Not setOld.Exists(k) Then
            wsNew.Cells(rNew, 1).Value = vNew(rn, cKeyN)
            wsNew.Cells(rNew, 2).Value = vNew(rn, FindHeader(rgN.Rows(1), "名称"))
            wsNew.Cells(rNew, 3).Value = vNew(rn, FindHeader(rgN.Rows(1), "単価"))
            wsNew.Cells(rNew, 4).Value = "新のみ"
            rNew = rNew + 1
        End If
    Next

    '整形
    Dim arrWs As Variant: arrWs = Array(wsNew, wsDel, wsChg)
    Dim w As Variant
    For Each w In arrWs
        w.Rows(1).Font.Bold = True
        w.Columns.AutoFit
    Next

    SpeedOff
    MsgBox "新規:" & rNew - 2 & " / 削除:" & rDel - 2 & " / 変更:" & rChg - 2
End Sub
VB
  • ポイント
    • 旧→新の差分: ファイル選択だけで比較できる。
    • 柔軟な項目: 見出し名ベースで項目を増減可能。

色付け・更新・同期への応用

  • 色で見える化: 差分セルを黄色、新規行を淡緑、削除行を淡赤で塗る（既出テンプレの色付けロジックと同様）。
  • 変更だけ更新: CSVの値でExcel側の差分セルだけ更新（“変更だけ更新”テンプレを流用）。
  • 完全同期: 削除→追加→更新の順でExcelマスタをCSVへ同期（“マスタと実績の同期”テンプレを流用）。

よくある落とし穴と対策

  • 文字コード違いで文字化けや一致漏れ
    • 対策: QueryTablesのTextFilePlatformをUTF-8（65001）かShift-JIS（932）に合わせる。
  • キー表記揺れで誤判定（新規/削除に化ける）
    • 対策: NormKey（Trim＋UCase）を両側に徹底。必要なら半角化や記号除去を追加。
  • 数値・日付の型ズレ
    • 対策: 数値はVal→CDbl、日付はFormat(“yyyy-mm-dd”)で統一。
  • 列見出し名がCSVとExcelで微妙に違う
    • 対策: “比較項目名”をCSVに合わせるか、名称マッピング（例：名称→商品名）を挟む。

例題で練習

'例1：CSV→Excelで新規/削除/変更を自動出力
Sub Example_DiffCsvToExcel()
    Diff_Csv_To_Excel
End Sub

'例2：2つのCSVファイルの差分を3分類で出力
Sub Example_DiffTwoCsvs()
    Diff_TwoCsvs
End Sub
VB

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