やりたかったこと
複数のExcelファイル（dwglist_n1～n8）に散らばった部品リストを、1つのブックに集約したい。
- output1: クロスリファレンス表（どのファイルにどの部品があるか〇で表示）
- output2: キーごとのメモ集約表（コメントを結合し、一部のファイルにしか無い場合は「n1,n3のみ」と注記）
対象規模は 300行 × 8ファイル。共有ドライブ上のファイルを扱う。
設計方針：「定数で全部変えられる」
列番号・行範囲・ソートキー・フィルタ条件をすべてコード冒頭の Const で定義した。実務でレイアウト変更があっても、定数を書き換えるだけで対応できる。
vb
' 読み込み元
Const SRC_COL_KEY As Long = 11 ' K列: 集約キー
Const SRC_COL_CMNT As Long = 27 ' AA列: コメント
Const SRC_LAST_COL As Long = 92 ' CN列: 最終列
' ソートキー（5段階）
Const SORT_KEY_1 As Long = 11 ' K列
Const SORT_KEY_2 As Long = 15 ' O列
Const SORT_KEY_3 As Long = 14 ' N列
' output2 範囲フィルタ
Const OUT2_KEY_FROM As String = "" ' 空なら制限なし
Const OUT2_KEY_TO As String = ""
' output2 列ソース
Const OUT2_COL_NO As Long = 20 ' T列 → no
Const OUT2_COL_NAME As Long = 26 ' Z列 → nameパフォーマンス：4つの高速化ポイント
1. 配列一括 Read/Write
セルを1つずつ読み書きすると、COM呼び出しが毎回発生して遅い。Range.Value で配列に一括読み込み→処理→一括書き込みにすることで、数十倍速くなる。
vb
data = .Range(.Cells(5, 1), .Cells(lastRow, 92)).Value ' 一括読み込み
ws1.Range(...).Value = out1 ' 一括書き込み2. Scripting.Dictionary で O(1) ルックアップ
キーの重複チェック・クロスリファレンスの存在判定に Scripting.Dictionary を使用。配列の線形検索 O(n) に比べて、ハッシュベースの O(1) で高速。
3. シェルソート
バブルソート O(n^2) → シェルソート O(n^1.3) に変更。300行程度なら体感差は小さいが、データ増加時に効いてくる。5段階の多段キー比較に対応。
4. ローカルTEMPコピー
共有ドライブ上のファイルを直接 Workbooks.Open すると、Excelがネットワーク越しに逐次アクセスするため遅い。fso.CopyFile でローカルの %TEMP% に一括コピーしてから開くことで、ネットワーク転送を1回に削減。
vb
fso.CopyFile srcFiles(i), tempPath, True ' 一括コピー
Set srcWb = Workbooks.Open(tempPath, ...) ' ローカルから読む
' ... 処理後 ...
fso.DeleteFile tempPath, True ' 後片付けはまったポイント
.bas ファイルの文字化け
VBEは Shift-JIS (CP932) でしか .bas を読めないが、エディタやリンターが勝手にUTF-8に変換してしまい、日本語コメントが文字化けした。
解決策: Pythonで Shift-JIS + CRLF の .bas を生成し、ZIP に格納して渡す。ZIPの中身はリンターが触れないので安全。
OneDrive パスの罠
ThisWorkbook.Path が https://d.docs.live.net/... のようなURL形式を返すことがある。ローカルパスへの自動変換は環境依存で不安定。
解決策: settingシートの C1 にベースフォルダパスを直接指定する方式に変更。自動解決を諦めて、確実な手動指定にした。
コード構成（最終版）
Sub RunAggregate()
├─ 1. settingシート読み込み（フォルダパス・ファイルリスト）
├─ 2. ファイルリスト取得＋存在チェック
├─ 3. 全ソースファイル読み込み → Dictionary格納
│ ├─ ローカルTEMPコピー
│ ├─ 配列一括読み込み
│ ├─ rowDict（全列データ保持）
│ └─ sortDict（ソートキー値保持）
├─ 4. シェルソート（多段キー）
├─ 5. output1 出力（全列＋〇マーク上書き）
└─ 6. output2 出力（no + name + 備考、範囲フィルタ付き）まとめ
- 定数化: レイアウト変更に強い。列番号・ソート順・フィルタ範囲がすべてコード冒頭で完結
- 配列一括処理 + Dictionary: VBAでも十分高速に処理できる
- 共有ドライブ対策: TEMPコピーで読み込み速度を改善
- エンコーディング対策: ZIP格納で文字化けを回避
- OneDrive対策: 自動解決より手動指定が確実
Option Explicit
' ============================================================
' 処理A : 部品リスト集約マクロ
' ────────────────────────────────────────────────────────────
' ・settingシートで指定したソースファイル(import/)を読み込み、
' output1 に〇クロスリファレンス表（ソース全列）、
' output2 にキーごとのメモ集約表を出力する。
' ・配列一括 Read/Write ＋ シェルソートで高速処理
' ============================================================
Sub RunAggregate()
' ==========================================================
' 定数定義：読み込み元（ソースファイル）の列番号
' ソースの列範囲は A(1)～CN(92)
' ==========================================================
Const SRC_COL_KEY As Long = 11 ' K列 : キー（集約キー）
Const SRC_COL_CMNT As Long = 27 ' AA列 : コメント
Const SRC_LAST_COL As Long = 92 ' CN列 : データ最終列
Const SRC_START_ROW As Long = 5 ' データ開始行（4行目はヘッダ）
' ==========================================================
' 定数定義：出力先（output1）の列番号・行番号
' ==========================================================
Const OUT_COL_KEY As Long = 11 ' K列 : キー表示位置
Const OUT_COL_WORK As Long = 27 ' AA列 : 作業（コメント）
Const OUT_COL_N As Long = 2 ' B列 : n列の開始位置
Const OUT_HDR_ROW As Long = 4 ' ヘッダ行（B4～I4 に n1,n2,...）
' ==========================================================
' 定数定義：出力先（output2）の列番号
' 1列目=no(T列), 2列目=name(Z列), 3列目=備考
' ==========================================================
Const OUT2_COL_NO As Long = 20 ' T列 : no（ソースのT列から取得）
Const OUT2_COL_NAME As Long = 26 ' Z列 : name（ソースのZ列から取得）
' ==========================================================
' 定数定義：settingシートの巡回範囲
' ==========================================================
Const START_ROW As Long = 2 ' ファイルリスト開始行
Const END_ROW As Long = 10 ' ファイルリスト終了行
' ==========================================================
' 定数定義：ファイル名トリム（output2 専用）
' output2 出力時のみ、キー値の先頭・末尾を除去する。
' output1 には影響しない。
' 不要なら "" にすればスキップされる。
' ==========================================================
Const FNAME_TRIM_PREFIX As String = "" ' 先頭から除去する文字列
Const FNAME_TRIM_SUFFIX As String = "" ' 末尾から除去する文字列
' ==========================================================
' 定数定義：output2 キー範囲フィルタ
' output2 に出力するキーの範囲を指定する。
' 文字列比較（昇順）で FROM ≦ キー ≦ TO の行のみ出力。
' 空文字 "" なら制限なし（全キー出力）。
' 例: "A00-0000" ～ "B99-9999" → A～B で始まるキーのみ
' ==========================================================
Const OUT2_KEY_FROM As String = "" ' 開始キー（空なら制限なし）
Const OUT2_KEY_TO As String = "" ' 終了キー（空なら制限なし）
' ==========================================================
' 定数定義：ソートキー（最大5段階）
' 出力の並び順を制御する。列番号を指定（0 = 使わない）。
' 例: K列(11)→O列(15)→N列(14) の順でソート
' ==========================================================
Const SORT_KEY_1 As Long = 11 ' 第1キー: K列
Const SORT_KEY_2 As Long = 15 ' 第2キー: O列
Const SORT_KEY_3 As Long = 14 ' 第3キー: N列
Const SORT_KEY_4 As Long = 0 ' 第4キー: なし
Const SORT_KEY_5 As Long = 0 ' 第5キー: なし
' ==========================================================
' 定数定義：区切り文字・日本語ラベル
' ==========================================================
Const SEP As String = "|"
Const MARU As String = "〇"
Const NOMI As String = "のみ"
Const HDR_KEY As String = "キー"
Const HDR_WORK As String = "作業"
Const HDR_NO As String = "no"
Const HDR_NAME As String = "name"
Const HDR_MEMO As String = "備考"
' ==========================================================
' 変数宣言
' ==========================================================
Dim fso As Object
Dim folderPath As String
Dim srcFiles() As String
Dim srcNames() As String
Dim nFiles As Long
Dim i As Long
Dim r As Long
Dim c As Long
' ----------------------------------------------------------
' 画面更新・再計算・イベントを一時停止（高速化）
' ----------------------------------------------------------
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error GoTo ErrHandler
Set fso = CreateObject("Scripting.FileSystemObject")
' ==========================================================
' 1. settingシート読み込み（必須）
' ==========================================================
Dim wsSetting As Worksheet
On Error Resume Next
Set wsSetting = ThisWorkbook.Sheets("setting")
On Error GoTo ErrHandler
' --- settingシートが無ければエラー終了 ---
If wsSetting Is Nothing Then
MsgBox "エラー: 'setting' シートが見つかりません。" & vbCrLf & _
"settingシートを作成してください。", vbCritical
GoTo Cleanup
End If
' --- C1 からベースフォルダパスを取得 ---
Dim baseFolder As String
baseFolder = Trim(CStr(wsSetting.Cells(1, 3).Value & ""))
If baseFolder <> "" Then
If Right(baseFolder, 1) <> "\" Then baseFolder = baseFolder & "\"
If Not fso.FolderExists(baseFolder) Then
MsgBox "エラー: ベースフォルダが見つかりません:" & vbCrLf & _
baseFolder & vbCrLf & vbCrLf & _
"settingシートのC1を確認してください。", vbCritical
GoTo Cleanup
End If
folderPath = baseFolder
Else
MsgBox "エラー: フォルダパスが取得できません。" & vbCrLf & _
"settingシートのC1にベースフォルダパスを設定してください。", vbCritical
GoTo Cleanup
End If
' ==========================================================
' 2. settingシートからファイルリストを取得
' （C列 START_ROW～END_ROW を巡回）
' ==========================================================
If wsSetting.Cells(START_ROW, 3).Value = "" Then
MsgBox "エラー: ファイルが設定されていません。" & vbCrLf & _
"settingシートのC" & START_ROW & "以降にファイル名を入力してください。", vbCritical
GoTo Cleanup
End If
' --- 配列を事前確保（最大ファイル数 = END_ROW - START_ROW + 1） ---
Dim maxFiles As Long
maxFiles = END_ROW - START_ROW + 1
ReDim srcFiles(1 To maxFiles)
ReDim srcNames(1 To maxFiles)
nFiles = 0
Dim si As Long, sj As Long, st As String
Dim cellVal As String
Dim fullPath As String
Dim missingFiles As String
missingFiles = ""
For r = START_ROW To END_ROW
cellVal = Trim(CStr(wsSetting.Cells(r, 3).Value & ""))
If cellVal <> "" Then
If InStr(cellVal, "\") > 0 Or InStr(cellVal, "/") > 0 Then
fullPath = cellVal
Else
fullPath = folderPath & cellVal
End If
If Not fso.FileExists(fullPath) Then
missingFiles = missingFiles & " 行 " & r & ": " & cellVal & vbCrLf
Else
nFiles = nFiles + 1
srcFiles(nFiles) = fullPath
Dim dispName As String
dispName = Trim(CStr(wsSetting.Cells(r, 2).Value & ""))
If dispName = "" Then
Dim bName As String
bName = fso.GetFileName(fullPath)
If InStr(bName, "_n") > 0 Then
Dim nm As String
nm = Mid(bName, InStr(bName, "_n") + 2)
dispName = "n" & Left(nm, Len(nm) - 5)
Else
dispName = Left(bName, Len(bName) - 5)
End If
End If
srcNames(nFiles) = dispName
End If
End If
Next r
If missingFiles <> "" Then
MsgBox "エラー: 以下のファイルが見つかりません:" & vbCrLf & vbCrLf & _
missingFiles & vbCrLf & _
"ベースフォルダ: " & folderPath, vbCritical
GoTo Cleanup
End If
If nFiles = 0 Then
MsgBox "エラー: 有効なファイルがありません。", vbCritical
GoTo Cleanup
End If
' ==========================================================
' 3. 全ソースファイル読み込み → Dictionaryに格納
' key = "K列値|コメント"
' value = Dictionary (ソース名 → True)
' ※ K列に値がある行を全て対象とする（〇フィルタなし）
' ==========================================================
Dim crossRef As Object ' 全キーのクロスリファレンス
Set crossRef = CreateObject("Scripting.Dictionary")
' --- ソート用：各compKeyのソートキー値を保持 ---
Dim sortDict As Object
Set sortDict = CreateObject("Scripting.Dictionary")
' --- output1用：各compKeyの全列データを保持（初回出現時） ---
Dim rowDict As Object
Set rowDict = CreateObject("Scripting.Dictionary")
' --- output1用：ソースのヘッダ行（最初のファイルから取得） ---
Dim hdrRow As Variant
hdrRow = Empty
' --- キーリスト：事前確保して後で切り詰め ---
Const INIT_KEYS As Long = 1024
Dim keyList() As String
Dim keyCount As Long
ReDim keyList(1 To INIT_KEYS)
keyCount = 0
Dim srcWb As Workbook
Dim data As Variant
Dim lastRow As Long
Dim keyVal As String
Dim cmnt As String
Dim compKey As String
' --- 共有ドライブ高速化：ローカルTEMPにコピーしてから読む ---
Dim tempDir As String
Dim tempPath As String
tempDir = Environ("TEMP")
If Right(tempDir, 1) <> "\" Then tempDir = tempDir & "\"
For i = 1 To nFiles
' ★ ネットワークファイルをローカルにコピー（一括転送で高速）
tempPath = tempDir & fso.GetFileName(srcFiles(i))
On Error Resume Next
fso.CopyFile srcFiles(i), tempPath, True
On Error GoTo ErrHandler
' ローカルコピーがあればそちらを開く、なければ元パスを開く
Dim openPath As String
If fso.FileExists(tempPath) Then
openPath = tempPath
Else
openPath = srcFiles(i)
End If
Set srcWb = Workbooks.Open(openPath, ReadOnly:=True, UpdateLinks:=0)
With srcWb.Sheets(1)
lastRow = .Cells(.Rows.Count, SRC_COL_KEY).End(xlUp).Row
If lastRow >= SRC_START_ROW Then
' --- ヘッダ行を最初のファイルから取得（1行前 = 4行目） ---
If IsEmpty(hdrRow) Then
hdrRow = .Range(.Cells(SRC_START_ROW - 1, 1), _
.Cells(SRC_START_ROW - 1, SRC_LAST_COL)).Value
End If
' --- A列～CN列 を配列に一括読み込み ---
data = .Range(.Cells(SRC_START_ROW, 1), .Cells(lastRow, SRC_LAST_COL)).Value
For r = 1 To UBound(data, 1)
keyVal = Trim(CStr(data(r, SRC_COL_KEY) & ""))
If keyVal <> "" Then
If IsEmpty(data(r, SRC_COL_CMNT)) Or _
CStr(data(r, SRC_COL_CMNT) & "") = "" Then
cmnt = ""
Else
cmnt = CStr(data(r, SRC_COL_CMNT))
End If
compKey = keyVal & SEP & cmnt
If Not crossRef.Exists(compKey) Then
Set crossRef(compKey) = CreateObject("Scripting.Dictionary")
keyCount = keyCount + 1
' 配列が足りなければ倍に拡張
If keyCount > UBound(keyList) Then
ReDim Preserve keyList(1 To UBound(keyList) * 2)
End If
keyList(keyCount) = compKey
' ★ 全列データを保持（初回出現時の値を使用）
Dim rv As Variant
ReDim rv(1 To SRC_LAST_COL)
For c = 1 To SRC_LAST_COL
rv(c) = data(r, c)
Next c
rowDict(compKey) = rv
' ★ ソート用の値を保持
Dim sv As Variant
sv = Array("", "", "", "", "")
If SORT_KEY_1 > 0 Then sv(0) = CStr(data(r, SORT_KEY_1) & "")
If SORT_KEY_2 > 0 Then sv(1) = CStr(data(r, SORT_KEY_2) & "")
If SORT_KEY_3 > 0 Then sv(2) = CStr(data(r, SORT_KEY_3) & "")
If SORT_KEY_4 > 0 Then sv(3) = CStr(data(r, SORT_KEY_4) & "")
If SORT_KEY_5 > 0 Then sv(4) = CStr(data(r, SORT_KEY_5) & "")
sortDict(compKey) = sv
End If
crossRef(compKey)(srcNames(i)) = True
End If
Next r
End If
End With
srcWb.Close False
' ★ TEMPのコピーを削除（後片付け）
On Error Resume Next
If fso.FileExists(tempPath) Then fso.DeleteFile tempPath, True
On Error GoTo ErrHandler
Next i
If keyCount = 0 Then
MsgBox "データが見つかりませんでした。", vbExclamation
GoTo Cleanup
End If
' --- keyList を実サイズに切り詰め ---
If keyCount < UBound(keyList) Then
ReDim Preserve keyList(1 To keyCount)
End If
' ==========================================================
' 4. シェルソート（SORT_KEY_1～5 の多段比較）
' バブルソート O(n^2) からシェルソート O(n^1.3) に高速化
' ==========================================================
Dim va As Variant, vb As Variant
Dim sk As Long
Dim needSwap As Boolean
Dim gap As Long, gi As Long, gj As Long
Dim tmp As String
gap = keyCount \ 2
Do While gap > 0
For gi = gap + 1 To keyCount
tmp = keyList(gi)
Dim tmpSort As Variant
tmpSort = sortDict(tmp)
gj = gi
Do While gj > gap
vb = sortDict(keyList(gj - gap))
needSwap = False
For sk = 0 To 4
If vb(sk) <> tmpSort(sk) Then
needSwap = (vb(sk) > tmpSort(sk))
Exit For
End If
Next sk
If Not needSwap Then Exit Do
keyList(gj) = keyList(gj - gap)
gj = gj - gap
Loop
keyList(gj) = tmp
Next gi
gap = gap \ 2
Loop
' ==========================================================
' 5. output1 : クロスリファレンス表を出力
' ソース全列(A～CN)のデータを表示し、
' B～I列のみ n1～n8 の〇マークで上書きする。
' ==========================================================
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets("output1")
ws1.Cells.Clear
Dim out1() As Variant
Dim outCols As Long
outCols = SRC_LAST_COL
ReDim out1(1 To keyCount + 1, 1 To outCols)
' --- ヘッダ行：ソースのヘッダをコピーし、B～I列のみ上書き ---
Dim parts() As String
If Not IsEmpty(hdrRow) Then
For c = 1 To outCols
out1(1, c) = hdrRow(1, c)
Next c
End If
For i = 1 To nFiles
out1(1, OUT_COL_N + i - 1) = srcNames(i)
Next i
' --- データ行：全列データをコピーし、B～I列のみ〇で上書き ---
Dim rowData As Variant
Dim cRef As Object
For r = 1 To keyCount
rowData = rowDict(keyList(r))
For c = 1 To outCols
out1(r + 1, c) = rowData(c)
Next c
' B～I列を〇で上書き（Dictionary参照を変数にキャッシュ）
Set cRef = crossRef(keyList(r))
For i = 1 To nFiles
If cRef.Exists(srcNames(i)) Then
out1(r + 1, OUT_COL_N + i - 1) = MARU
Else
out1(r + 1, OUT_COL_N + i - 1) = ""
End If
Next i
Next r
ws1.Range(ws1.Cells(OUT_HDR_ROW, 1), _
ws1.Cells(OUT_HDR_ROW + keyCount, outCols)).Value = out1
' --- B4～I4（n列ヘッダ）を縦書き表示にする ---
Dim lastNCol As Long
lastNCol = OUT_COL_N + nFiles - 1
If lastNCol > 9 Then lastNCol = 9
If lastNCol >= OUT_COL_N Then
ws1.Range(ws1.Cells(OUT_HDR_ROW, OUT_COL_N), _
ws1.Cells(OUT_HDR_ROW, lastNCol)).Orientation = 90
End If
' --- out1 配列を解放（メモリ節約） ---
Erase out1
' ==========================================================
' 6. output2 : キーごとのメモ集約表を出力
' 1列目: no（ソースのT列）
' 2列目: name（ソースのZ列）
' 3列目: 備考（コメント集約）
' ※ OUT2_KEY_FROM / OUT2_KEY_TO で範囲フィルタ可能
' ==========================================================
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Sheets("output2")
ws2.Cells.Clear
' --- キーごとにコメント・no・nameを集約する Dictionary ---
Dim fnDict As Object ' キー値 → 結合メモ文字列
Dim fnNoDict As Object ' キー値 → no（初回出現時のT列値）
Dim fnNmDict As Object ' キー値 → name（初回出現時のZ列値）
Dim fnList() As String ' 出現順のキーリスト
Dim fnCount As Long
Set fnDict = CreateObject("Scripting.Dictionary")
Set fnNoDict = CreateObject("Scripting.Dictionary")
Set fnNmDict = CreateObject("Scripting.Dictionary")
ReDim fnList(1 To keyCount) ' 最大でkeyCount個
fnCount = 0
For r = 1 To keyCount
parts = Split(keyList(r), SEP)
keyVal = parts(0)
cmnt = ""
If UBound(parts) >= 1 Then cmnt = parts(1)
' ★ output2 専用：キー値トリム処理
If FNAME_TRIM_PREFIX <> "" Then
If Left(keyVal, Len(FNAME_TRIM_PREFIX)) = FNAME_TRIM_PREFIX Then
keyVal = Mid(keyVal, Len(FNAME_TRIM_PREFIX) + 1)
End If
End If
If FNAME_TRIM_SUFFIX <> "" Then
If Right(keyVal, Len(FNAME_TRIM_SUFFIX)) = FNAME_TRIM_SUFFIX Then
keyVal = Left(keyVal, Len(keyVal) - Len(FNAME_TRIM_SUFFIX))
End If
End If
' ★ 範囲フィルタ
Dim inRange As Boolean
inRange = True
If OUT2_KEY_FROM <> "" Then
If keyVal < OUT2_KEY_FROM Then inRange = False
End If
If OUT2_KEY_TO <> "" Then
If keyVal > OUT2_KEY_TO Then inRange = False
End If
If inRange Then
' --- 全ソースに存在するか判定 ---
Dim allOK As Boolean
Dim presList As String
Dim sName As String
allOK = True
presList = ""
Set cRef = crossRef(keyList(r))
For i = 1 To nFiles
If cRef.Exists(srcNames(i)) Then
sName = srcNames(i)
If FNAME_TRIM_PREFIX <> "" Then
If Left(sName, Len(FNAME_TRIM_PREFIX)) = FNAME_TRIM_PREFIX Then
sName = Mid(sName, Len(FNAME_TRIM_PREFIX) + 1)
End If
End If
If FNAME_TRIM_SUFFIX <> "" Then
If Right(sName, Len(FNAME_TRIM_SUFFIX)) = FNAME_TRIM_SUFFIX Then
sName = Left(sName, Len(sName) - Len(FNAME_TRIM_SUFFIX))
End If
End If
If presList <> "" Then presList = presList & ","
presList = presList & sName
Else
allOK = False
End If
Next i
' --- メモ文字列生成 ---
Dim entry As String
Dim dispCmnt As String
If cmnt <> "" Then
dispCmnt = cmnt
Else
dispCmnt = "＿"
End If
If allOK Then
entry = dispCmnt
Else
entry = dispCmnt & presList & NOMI
End If
' --- 同じキー値のエントリを結合 ---
If Not fnDict.Exists(keyVal) Then
fnDict(keyVal) = entry
fnCount = fnCount + 1
fnList(fnCount) = keyVal
' ★ no(T列), name(Z列) を rowDict から取得（初回出現時）
rowData = rowDict(keyList(r))
fnNoDict(keyVal) = CStr(rowData(OUT2_COL_NO) & "")
fnNmDict(keyVal) = CStr(rowData(OUT2_COL_NAME) & "")
Else
If entry <> "" Then
If fnDict(keyVal) <> "" Then
fnDict(keyVal) = fnDict(keyVal) & " " & entry
Else
fnDict(keyVal) = entry
End If
End If
End If
End If ' inRange
Next r
' --- 配列に詰めて一括書き込み（3列: no, name, 備考） ---
If fnCount > 0 Then
Dim out2() As Variant
ReDim out2(1 To fnCount + 1, 1 To 3)
out2(1, 1) = HDR_NO
out2(1, 2) = HDR_NAME
out2(1, 3) = HDR_MEMO
For r = 1 To fnCount
out2(r + 1, 1) = fnNoDict(fnList(r))
out2(r + 1, 2) = fnNmDict(fnList(r))
out2(r + 1, 3) = fnDict(fnList(r))
Next r
ws2.Range(ws2.Cells(1, 1), ws2.Cells(fnCount + 1, 3)).Value = out2
End If
' ==========================================================
' 完了メッセージ
' ==========================================================
MsgBox "完了しました！" & vbCrLf & _
"フォルダ: " & folderPath & vbCrLf & _
"ソース: " & nFiles & " ファイル" & vbCrLf & _
"output1: " & keyCount & " 行" & vbCrLf & _
"output2: " & fnCount & " 行", vbInformation
Cleanup:
' ----------------------------------------------------------
' 画面更新・再計算・イベントを復元
' ----------------------------------------------------------
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Exit Sub
ErrHandler:
' ----------------------------------------------------------
' 予期しないエラーのハンドリング
' ----------------------------------------------------------
MsgBox "エラーが発生しました: " & Err.Description & vbCrLf & _
"パス: " & folderPath, vbCritical
Resume Cleanup
End Sub
コメント