20260413mon

Published: at 15:00

20260413mon

Module（フォルダ選択・パスクリア）

Sub SelectFolder1()
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)

    With fd
        .Title = "フォルダを選択してください（A3用）"
        If .Show = -1 Then
            ThisWorkbook.Sheets("マクロ").Range("A3").Value = .SelectedItems(1)
        End If
    End With
End Sub

Sub SelectFolder2()
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)

    With fd
        .Title = "フォルダを選択してください（A8用）"
        If .Show = -1 Then
            ThisWorkbook.Sheets("マクロ").Range("A8").Value = .SelectedItems(1)
        End If
    End With
End Sub
Sub ClearEAI1Path()
    Range("A3").ClearContents
End Sub

Sub ClearEAI2Path()
    Range("A8").ClearContents
End Sub

M_Main

Option Explicit

'=== 定数 ===
Private Const SHEET_MACRO As String = "マクロ"
Private Const CELL_EAI1_PATH As String = "A3"
Private Const CELL_EAI2_PATH As String = "A8"
Private Const CELL_MSG_START As String = "A10"
Private Const TEMPLATE_NAME As String = "結果template.xlsx"
Private Const RESULT_FOLDER As String = "結果"

Public Sub Run_Compare()
    Dim wsMacro As Worksheet
    Dim eai1Path As String, eai2Path As String
    Dim basePath As String, templatePath As String, resultFolderPath As String
    Dim wsResult As Worksheet
    Dim dict1 As Object, dict2 As Object
    Dim skipList As Object, dupList As Object

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error GoTo ErrHandler

    Set wsMacro = ThisWorkbook.Worksheets(SHEET_MACRO)

    '--- 前処理：メッセージクリア ---
    ClearMessages wsMacro

    '--- 入力取得 ---
    eai1Path = Trim(wsMacro.Range(CELL_EAI1_PATH).Value)
    eai2Path = Trim(wsMacro.Range(CELL_EAI2_PATH).Value)

    If eai1Path = "" Or eai2Path = "" Then
        MsgBox "EAI1およびEAI2のフォルダパスを入力してください。", vbExclamation
        GoTo CleanUp
    End If

    If Dir(eai1Path, vbDirectory) = "" Then
        MsgBox "EAI1フォルダが存在しません: " & eai1Path, vbExclamation
        GoTo CleanUp
    End If
    If Dir(eai2Path, vbDirectory) = "" Then
        MsgBox "EAI2フォルダが存在しません: " & eai2Path, vbExclamation
        GoTo CleanUp
    End If

    '--- パス構築 ---
    basePath = ThisWorkbook.Path & "\"
    templatePath = basePath & TEMPLATE_NAME
    resultFolderPath = basePath & RESULT_FOLDER & "\"

    If Dir(templatePath) = "" Then
        MsgBox "テンプレートが存在しません: " & templatePath, vbExclamation
        GoTo CleanUp
    End If
    If Dir(resultFolderPath, vbDirectory) = "" Then
        MsgBox "結果フォルダが存在しません: " & resultFolderPath, vbExclamation
        GoTo CleanUp
    End If

    '--- 結果シート作成 ---
    Set wsResult = CreateResultSheet()

    '--- ファイル一覧取得 ---
    Set skipList = CreateObject("System.Collections.ArrayList")
    Set dupList = CreateObject("System.Collections.ArrayList")

    Set dict1 = M_FileUtil.BuildFileDict(eai1Path, "EAI1", skipList, dupList)
    Set dict2 = M_FileUtil.BuildFileDict(eai2Path, "EAI2", skipList, dupList)

    '--- 突き合わせ処理 ---
    M_Compare.RunComparison wsResult, dict1, dict2, eai1Path, eai2Path, _
                            templatePath, resultFolderPath

    '--- 後処理：メッセージ出力 ---
    WriteMessages wsMacro, skipList, dupList

CleanUp:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "処理が完了しました。", vbInformation
    Exit Sub

ErrHandler:
    MsgBox "エラーが発生しました: " & vbCrLf & Err.Description, vbCritical
    Resume CleanUp
End Sub

'=== 結果シート作成 ===
Private Function CreateResultSheet() As Worksheet
    Dim ws As Worksheet
    Dim sheetName As String

    sheetName = Format(Now, "yyyymmddhhnn")

    Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = sheetName

    ws.Range("B2").Value = "EAI1_GUID"
    ws.Range("C2").Value = "EAI2_GUID"
    ws.Range("D2").Value = "結果"

    Set CreateResultSheet = ws
End Function

'=== メッセージクリア ===
Private Sub ClearMessages(ws As Worksheet)
    Dim lastRow As Long
    lastRow = ws.cells(ws.Rows.Count, "A").End(xlUp).row
    If lastRow >= 10 Then
        ws.Range("A10:A" & lastRow).ClearContents
    End If
End Sub

'=== メッセージ出力 ===
Private Sub WriteMessages(ws As Worksheet, skipList As Object, dupList As Object)
    Dim row As Long
    Dim i As Long

    row = 10
    ws.cells(row, "A").Value = "処理完了: " & Format(Now, "yyyy/mm/dd hh:nn")
    row = row + 1

    For i = 0 To skipList.Count - 1
        ws.cells(row, "A").Value = skipList(i)
        row = row + 1
    Next i

    For i = 0 To dupList.Count - 1
        ws.cells(row, "A").Value = dupList(i)
        row = row + 1
    Next i
End Sub

M_FileUtil

Option Explicit

'=== フォルダ内CSVを走査し、比較キー辞書を構築 ===
Public Function BuildFileDict(folderPath As String, label As String, _
                              skipList As Object, dupList As Object) As Object
    Dim dict As Object
    Dim fileName As String
    Dim key As String
    Dim normalizedPath As String

    Set dict = CreateObject("Scripting.Dictionary")

    normalizedPath = folderPath
    If Right(normalizedPath, 1) <> "\" Then normalizedPath = normalizedPath & "\"

    fileName = Dir(normalizedPath & "*.csv")
    Do While fileName <> ""
        key = ExtractCompareKey(fileName)

        If key = "" Then
            skipList.Add "[スキップ] " & label & ": " & fileName
        ElseIf dict.Exists(key) Then
            '重複：既存エントリも除外
            dict.Remove key
            dupList.Add "[重複キー] " & label & ": " & key
        Else
            dict.Add key, fileName
        End If

        fileName = Dir()
    Loop

    Set BuildFileDict = dict
End Function

'=== 比較キー抽出：最初の_と最後の_の間 ===
Public Function ExtractCompareKey(fileName As String) As String
    Dim nameWithoutExt As String
    Dim firstUnderscore As Long, lastUnderscore As Long
    Dim dotPos As Long

    '拡張子除去
    dotPos = InStrRev(fileName, ".")
    If dotPos > 0 Then
        nameWithoutExt = Left(fileName, dotPos - 1)
    Else
        nameWithoutExt = fileName
    End If

    firstUnderscore = InStr(nameWithoutExt, "_")
    lastUnderscore = InStrRev(nameWithoutExt, "_")

    '_が1個以下ならスキップ対象
    If firstUnderscore = 0 Or firstUnderscore = lastUnderscore Then
        ExtractCompareKey = ""
        Exit Function
    End If

    ExtractCompareKey = Mid(nameWithoutExt, firstUnderscore + 1, _
                            lastUnderscore - firstUnderscore - 1)
End Function

'=== CSVをシートに書き込み（UTF-8、カンマ区切り、そのまま） ===
Public Sub WriteCsvToSheet(csvPath As String, ws As Worksheet, startRow As Long)
    Dim stream As Object
    Dim content As String
    Dim lines() As String
    Dim cells() As String
    Dim i As Long, j As Long
    Dim writeArr As Variant
    Dim maxCol As Long
    Dim delimiter As String

    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2 'Text
    stream.Charset = "UTF-8"
    stream.Open
    stream.LoadFromFile csvPath
    content = stream.ReadText
    stream.Close

    If Len(content) = 0 Then Exit Sub

    '行分割のための区切り文字を判定（中身は変更しない）
    If InStr(content, vbCrLf) > 0 Then
        delimiter = vbCrLf
    ElseIf InStr(content, vbLf) > 0 Then
        delimiter = vbLf
    ElseIf InStr(content, vbCr) > 0 Then
        delimiter = vbCr
    Else
        delimiter = vbCrLf '改行なし=1行のみ
    End If

    lines = Split(content, delimiter)

    '最大列数を算出
    maxCol = 0
    For i = 0 To UBound(lines)
        cells = Split(lines(i), ",")
        If UBound(cells) + 1 > maxCol Then maxCol = UBound(cells) + 1
    Next i

    If maxCol = 0 Then Exit Sub

    '2次元配列に詰めて一括書き込み
    ReDim writeArr(0 To UBound(lines), 0 To maxCol - 1)
    For i = 0 To UBound(lines)
        cells = Split(lines(i), ",")
        For j = 0 To UBound(cells)
            writeArr(i, j) = cells(j)
        Next j
    Next i

    ws.Range(ws.cells(startRow, 1), _
             ws.cells(startRow + UBound(lines), maxCol)).Value = writeArr
End Sub

M_Compare

Option Explicit

'=== 突き合わせ処理本体 ===
Public Sub RunComparison(wsResult As Worksheet, dict1 As Object, dict2 As Object, _
                         eai1Path As String, eai2Path As String, _
                         templatePath As String, resultFolderPath As String)
    Dim allKeys As Object
    Dim key As Variant
    Dim row As Long
    Dim eai1Full As String, eai2Full As String

    Set allKeys = CreateObject("Scripting.Dictionary")

    For Each key In dict1.Keys
        If Not allKeys.Exists(key) Then allKeys.Add key, 1
    Next key
    For Each key In dict2.Keys
        If Not allKeys.Exists(key) Then allKeys.Add key, 1
    Next key

    eai1Full = NormalizePath(eai1Path)
    eai2Full = NormalizePath(eai2Path)

    row = 3 'ヘッダが2行目なので3行目から

    For Each key In allKeys.Keys
        If dict1.Exists(key) And dict2.Exists(key) Then
            ProcessMatch wsResult, row, CStr(key), _
                         eai1Full & dict1(key), eai2Full & dict2(key), _
                         dict1(key), dict2(key), templatePath, resultFolderPath
        ElseIf dict1.Exists(key) Then
            ProcessSingleSide wsResult, row, CStr(key), _
                              eai1Full & dict1(key), dict1(key), "", _
                              templatePath, resultFolderPath, True
        Else
            ProcessSingleSide wsResult, row, CStr(key), _
                              eai2Full & dict2(key), "", dict2(key), _
                              templatePath, resultFolderPath, False
        End If
        row = row + 1
    Next key
End Sub

'=== 一致処理 ===
Private Sub ProcessMatch(wsResult As Worksheet, row As Long, key As String, _
                         csv1Path As String, csv2Path As String, _
                         fileName1 As String, fileName2 As String, _
                         templatePath As String, resultFolderPath As String)
    Dim destPath As String
    Dim wbResult As Workbook
    Dim wsEai1 As Worksheet, wsEai2 As Worksheet

    wsResult.cells(row, "B").Value = fileName1
    wsResult.cells(row, "C").Value = fileName2

    destPath = resultFolderPath & key & ".xlsx"
    FileCopy templatePath, destPath

    Set wbResult = Workbooks.Open(destPath)
    Set wsEai1 = wbResult.Worksheets("EAI1")
    Set wsEai2 = wbResult.Worksheets("EAI2")

    M_FileUtil.WriteCsvToSheet csv1Path, wsEai1, 2
    M_FileUtil.WriteCsvToSheet csv2Path, wsEai2, 2

    If AreSheetsEqual(wsEai1, wsEai2) Then
        wsResult.cells(row, "D").Value = "○"
    Else
        wsResult.cells(row, "D").Value = "×"
    End If

    wbResult.Close SaveChanges:=True
End Sub

'=== 片側のみ処理 ===
Private Sub ProcessSingleSide(wsResult As Worksheet, row As Long, key As String, _
                              csvPath As String, fileName1 As String, fileName2 As String, _
                              templatePath As String, resultFolderPath As String, _
                              isEai1 As Boolean)
    Dim destPath As String
    Dim wbResult As Workbook
    Dim targetSheet As String

    wsResult.cells(row, "B").Value = fileName1
    wsResult.cells(row, "C").Value = fileName2
    wsResult.cells(row, "D").Value = "一致ファイル無し"

    destPath = resultFolderPath & key & ".xlsx"
    FileCopy templatePath, destPath

    Set wbResult = Workbooks.Open(destPath)

    If isEai1 Then
        targetSheet = "EAI1"
    Else
        targetSheet = "EAI2"
    End If

    M_FileUtil.WriteCsvToSheet csvPath, wbResult.Worksheets(targetSheet), 2

    wbResult.Close SaveChanges:=True
End Sub

'=== 完全一致判定（行順も含めて比較、空白・改行は正規化） ===
Private Function AreSheetsEqual(ws1 As Worksheet, ws2 As Worksheet) As Boolean
    Dim arr1() As String, arr2() As String

    arr1 = GetNormalizedRows(ws1)
    arr2 = GetNormalizedRows(ws2)

    If (UBound(arr1) <> UBound(arr2)) Then
        AreSheetsEqual = False
        Exit Function
    End If

    '-1始まりのとき（両方空）は一致扱い
    If UBound(arr1) = -1 Then
        AreSheetsEqual = True
        Exit Function
    End If

    Dim i As Long
    For i = 0 To UBound(arr1)
        If arr1(i) <> arr2(i) Then
            AreSheetsEqual = False
            Exit Function
        End If
    Next i

    AreSheetsEqual = True
End Function
'=== シートの2行目以降を行ごとの文字列配列として取得 ===
Private Function GetRows(ws As Worksheet) As String()
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim result() As String
    Dim rowStr As String
    Dim data As Variant

    lastRow = ws.cells(ws.Rows.Count, 1).End(xlUp).row
    lastCol = ws.cells(1, ws.Columns.Count).End(xlToLeft).Column

    If lastRow < 2 Then
        ReDim result(-1 To -1)
        GetRows = result
        Exit Function
    End If

    data = ws.Range(ws.cells(2, 1), ws.cells(lastRow, lastCol)).Value

    ReDim result(0 To lastRow - 2)

    If IsArray(data) Then
        For i = 1 To UBound(data, 1)
            rowStr = ""
            For j = 1 To UBound(data, 2)
                rowStr = rowStr & CStr(data(i, j) & "") & Chr(1)
            Next j
            result(i - 1) = rowStr
        Next i
    Else
        result(0) = CStr(data & "") & Chr(1)
    End If

    GetRows = result
End Function

'=== セル値正規化：空白・改行除去 ===
Private Function NormalizeCell(v As Variant) As String
    Dim s As String
    If IsNull(v) Or IsEmpty(v) Then
        NormalizeCell = ""
        Exit Function
    End If
    s = CStr(v)
    s = Replace(s, vbCrLf, "")
    s = Replace(s, vbLf, "")
    s = Replace(s, vbCr, "")
    s = Trim(s)
    NormalizeCell = s
End Function

'=== パス末尾に\を付与 ===
Private Function NormalizePath(p As String) As String
    If Right(p, 1) = "\" Then
        NormalizePath = p
    Else
        NormalizePath = p & "\"
    End If
End Function

Q: Excelシート同士の比較時の正規化はどうしますか？ A: 比較時も何もしない（完全にそのまま比較）4月13日了解です。書き込みも比較も一切手を加えず、ありのままで扱います。 変更箇所 ① M_FileUtil.WriteCsvToSheet を書き換え 改行コード正規化も末尾改行除去もやめて、ファイルから読んだ内容を素直にセルに入れます。ただしSplitのために行区切りは必要なので、vbCrLf/vbLf/vbCr のどれで区切られていても行として認識できるよう、行分割のためだけに改行コードを判定します（セルの中身自体は変更しません）。 vba’=== CSVをシートに書き込み（UTF-8、カンマ区切り、そのまま） === Public Sub WriteCsvToSheet(csvPath As String, ws As Worksheet, startRow As Long) Dim stream As Object Dim content As String Dim lines() As String Dim cells() As String Dim i As Long, j As Long Dim writeArr As Variant Dim maxCol As Long Dim delimiter As String

Set stream = CreateObject("ADODB.Stream")
stream.Type = 2 'Text
stream.Charset = "UTF-8"
stream.Open
stream.LoadFromFile csvPath
content = stream.ReadText
stream.Close

If Len(content) = 0 Then Exit Sub

'行分割のための区切り文字を判定（中身は変更しない）
If InStr(content, vbCrLf) > 0 Then
    delimiter = vbCrLf
ElseIf InStr(content, vbLf) > 0 Then
    delimiter = vbLf
ElseIf InStr(content, vbCr) > 0 Then
    delimiter = vbCr
Else
    delimiter = vbCrLf '改行なし=1行のみ
End If

lines = Split(content, delimiter)

'最大列数を算出
maxCol = 0
For i = 0 To UBound(lines)
    cells = Split(lines(i), ",")
    If UBound(cells) + 1 > maxCol Then maxCol = UBound(cells) + 1
Next i

If maxCol = 0 Then Exit Sub

'2次元配列に詰めて一括書き込み
ReDim writeArr(0 To UBound(lines), 0 To maxCol - 1)
For i = 0 To UBound(lines)
    cells = Split(lines(i), ",")
    For j = 0 To UBound(cells)
        writeArr(i, j) = cells(j)
    Next j
Next i

ws.Range(ws.Cells(startRow, 1), _
         ws.Cells(startRow + UBound(lines), maxCol)).Value = writeArr

End Sub 変更点：

Replace(content, vbCrLf, vbLf) などの改行正規化を削除 末尾改行除去の Do While ループを削除 行分割の区切り文字を動的に判定（最初に見つかった改行コードを使用）

⚠️ 1点だけ注意：混在した改行コードが1ファイル内にあった場合（例：一部が vbCrLf、一部が vbLf）、最初に見つかった方で分割するので、分割しきれなかった改行がセルの値に含まれたまま入ります。これはこれで「そのまま」と言えばそうなので、仕様通りかと。気になるようなら教えてください。

② M_Compare.GetNormalizedRows から正規化を削除 関数名から「Normalized」を外して GetRows に変えます。NormalizeCell 関数も不要になるので削除します。 vba’=== シートの2行目以降を行ごとの文字列配列として取得 === Private Function GetRows(ws As Worksheet) As String() Dim lastRow As Long, lastCol As Long Dim i As Long, j As Long Dim result() As String Dim rowStr As String Dim data As Variant

lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

If lastRow < 2 Then
    ReDim result(-1 To -1)
    GetRows = result
    Exit Function
End If

data = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol)).Value

ReDim result(0 To lastRow - 2)

If IsArray(data) Then
    For i = 1 To UBound(data, 1)
        rowStr = ""
        For j = 1 To UBound(data, 2)
            rowStr = rowStr & CStr(data(i, j) & "") & Chr(1)
        Next j
        result(i - 1) = rowStr
    Next i
Else
    result(0) = CStr(data & "") & Chr(1)
End If

GetRows = result

End Function 変更点：

NormalizeCell(data(i, j)) → CStr(data(i, j) & "") に変更

& "" は Null/Empty 対策（エラー回避のため。値の中身自体には影響しません）

関数名を GetNormalizedRows → GetRows に変更

③ M_Compare.AreSheetsEqual の呼び出し名を修正 GetNormalizedRows → GetRows の呼び出しに変えるだけです： vbaPrivate Function AreSheetsEqual(ws1 As Worksheet, ws2 As Worksheet) As Boolean Dim arr1() As String, arr2() As String

arr1 = GetRows(ws1)   '← 変更
arr2 = GetRows(ws2)   '← 変更

' 以下そのまま
If (UBound(arr1) <> UBound(arr2)) Then
    AreSheetsEqual = False
    Exit Function
End If

If UBound(arr1) = -1 Then
    AreSheetsEqual = True
    Exit Function
End If

Dim i As Long
For i = 0 To UBound(arr1)
    If arr1(i) <> arr2(i) Then
        AreSheetsEqual = False
        Exit Function
    End If
Next i

AreSheetsEqual = True

End Function

④ NormalizeCell は削除 M_Compare の中の NormalizeCell 関数はもう使わないのでまるごと削除してください。

仕様書の該当箇所も更新 変更前：

各シートの全データを行単位の配列として取得 各セルの値について、前後の空白と改行コードを除去して正規化 行単位でソート（順序の違いを無視するため） 行数・各行の内容がすべて一致すれば「完全一致」

変更後：

各シートの2行目以降のデータを行単位で取得 行数・各行の内容が出現順通りにすべて一致すれば「完全一致」（値は一切加工せず、そのまま比較）

仕様書

仕様書（最終確定版） 前提条件

このワークブックを「マクロExcel」と呼ぶ 「マクロExcel」には「マクロ」シートがあり、実行ボタンは「マクロ」シート上に配置 「マクロExcel」と同階層に以下が存在する

結果template.xlsx（EAI1・EAI2 シートを持ち、1行目にヘッダあり） 結果 フォルダ

入力 セル内容マクロ!A3EAI1フォルダパスマクロ!A8EAI2フォルダパス

対象ファイル形式：CSV（カンマ区切り、UTF-8、ヘッダ行なし） ダブルクォートによるカンマエスケープは考慮しない

用語定義

比較キー：ファイル名のうち、最初の _ と最後の _ の間の文字列

例：ABC_order_20260101.csv → order

有効ファイル：ファイル名に _ が2個以上あるCSVファイル スキップファイル：_ が1個以下のファイル（比較キーが取れない）

処理フロー

  1. 前処理

「マクロ」シートのA10以降の既存メッセージをクリア 「マクロExcel」に新シートを作成（＝結果シート）、名前は yyyymmddhhmm 結果シートのヘッダを作成

B2：EAI1_GUID C2：EAI2_GUID D2：結果

  1. ファイル一覧取得 EAI1・EAI2フォルダそれぞれで：

CSVファイル一覧を取得 各ファイルを比較キーで分類

_ が1個以下 → スキップリストに追加 それ以外 → 比較キー辞書に格納

同じ比較キーが既に存在する場合、そのキーを重複リストに追加し、比較対象から除外

  1. 突き合わせ処理 結果シートの3行目から順に書き込み。 パターンA：一致

結果シートに追記（B列=EAI1ファイル名、C列=EAI2ファイル名） 結果template.xlsx を 結果 フォルダに {比較キー}.xlsx としてコピー（既存なら上書き） 比較結果Excelを開く EAI1のCSVを読み込み、EAI1 シートの2行目から書き込み EAI2のCSVを読み込み、EAI2 シートの2行目から書き込み 完全一致判定 → D列に ○ または × 保存して閉じる

パターンB：EAI1のみ

結果シートに追記（B列=EAI1ファイル名、C列=空、D列=一致ファイル無し） テンプレートをコピー EAI1のCSVを EAI1 シートの2行目から書き込み 保存して閉じる

パターンC：EAI2のみ

結果シートに追記（B列=空、C列=EAI2ファイル名、D列=一致ファイル無し） テンプレートをコピー EAI2のCSVを EAI2 シートの2行目から書き込み 保存して閉じる

  1. 完全一致判定ロジック EAI1 シートと EAI2 シートの2行目以降を比較：

各シートのデータを行単位の配列として取得 各セルの値について、前後の空白と改行コードを除去して正規化 行単位でソート（順序の違いを無視） 行数・各行の内容がすべて一致すれば「完全一致」

  1. 後処理 「マクロ」シートのA10以降に1行1件で出力：

A10：処理完了メッセージ（例：処理完了： 2026/04/13 14:30） A11以降：スキップファイル（1件1行）

例：[スキップ] EAI1: data.csv 例：[スキップ] EAI2: xxx.csv

続き：重複キー（1件1行）

例：[重複キー] EAI1: order 例：[重複キー] EAI2: master

最後にMsgBoxで完了通知。