📝 はじめに
Access で作ったクエリの SQL 文って、VBA のエディタや SQL ビューだと読みづらくないですか？
特に長い JOIN がネストしたものや UNION ALL を含む複雑なクエリは、インデントや色付けがないので可読性が悪い…。
そこで今回、
- Access のすべてのクエリを走査して
- SQL 文を**整形（Pretty Print）**して
- Excel に 1クエリ＝1シート で出力
- さらに エディタ風の色分け を適用
する VBA モジュールを作ってみました 💡
Option Compare Database
Option Explicit
' ========= ユーザー調整用オプション =========
Private Const OPT_INCLUDE_SYSTEM_QUERIES As Boolean = False ' MSys/一時(~名)を含めるか
Private Const OPT_INCLUDE_ACTION_QUERIES As Boolean = False ' INSERT/UPDATE/DELETE/DDL を含めるか
Private Const OPT_SHEET_FONT_NAME As String = "Consolas" ' 等幅推奨
Private Const OPT_SHEET_FONT_SIZE As Long = 10
Private Const OPT_SQL_COL_WIDTH As Double = 120 ' SQL表示列の幅（B列）
Private Const OPT_ENABLE_SYNTAX_COLOR As Boolean = True ' シンタックス色分けを有効化
Private Const OPT_INDENT_SPACES As Long = 2 ' インデント幅（スペース）
' ============================================
' ▶️ エントリポイント（これだけ実行）
Public Sub ExportAllQuerySQLs()
On Error GoTo ErrHandler
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim xlApp As Object, xlBook As Object, toc As Object, ws As Object
Dim downloads As String, filePath As String
Dim queries As Collection
Dim i As Long, added As Long
Dim errLog As Collection
Set db = CurrentDb
Set queries = New Collection
Set errLog = New Collection
' 📁 保存先（Downloads）
downloads = GetDownloadsPath()
If Len(downloads) = 0 Then
MsgBox "Downloads フォルダを特定できませんでした。USERPROFILE 環境変数をご確認ください。", vbExclamation
Exit Sub
End If
filePath = downloads & "\QuerySQLExport_" & Format(Now, "yyyymmdd_hhnnss") & ".xlsx"
' 🧮 対象クエリ抽出
For Each qdf In db.QueryDefs
If IsTargetQuery(qdf) Then
queries.Add qdf.Name
End If
Next
If queries.Count = 0 Then
MsgBox "出力対象のクエリ（SQLを持つもの）が見つかりませんでした。", vbInformation
Exit Sub
End If
' 📊 進捗バー
SysCmd acSysCmdInitMeter, "クエリのSQLをExcelへ出力中…", queries.Count
' 🧯 Excel起動（遅延バインディング）
On Error Resume Next
Set xlApp = CreateObject("Excel.Application")
On Error GoTo ErrHandler
If xlApp Is Nothing Then
MsgBox "Excel を起動できませんでした。インストール状況をご確認ください。", vbCritical
GoTo Cleanup
End If
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
' 📇 TOC（目次）作成
Set toc = xlBook.Sheets(1)
toc.Name = "TOC"
InitSheetStyle toc
WriteTOCHeader toc
added = 0
' 🌀 各クエリ処理
For i = 1 To queries.Count
Dim name As String, sqlText As String, sqlFmt As String
Dim params As String, targetSheetName As String
name = CStr(queries(i))
On Error Resume Next
sqlText = db.QueryDefs(name).SQL
On Error GoTo ErrHandler
If Len(Trim$(sqlText)) = 0 Then
LogError errLog, name, "SQL が空、または取得できませんでした。"
GoTo NextLoop
End If
' 🧼 整形
sqlFmt = FormatSQLPretty(sqlText)
params = GetQueryParametersInfo(db.QueryDefs(name))
' 🗂️ シート生成
targetSheetName = MakeSafeUniqueSheetName(xlBook, name)
Set ws = xlBook.Sheets.Add(After:=xlBook.Sheets(xlBook.Sheets.Count))
ws.Name = targetSheetName
InitSheetStyle ws
' 📝 書き込み（メタ + SQL）
With ws
.Cells(1, 1).Value = "Query Name"
.Cells(1, 2).Value = name
.Cells(2, 1).Value = "Created"
.Cells(2, 2).Value = Now
.Cells(3, 1).Value = "Parameters"
.Cells(3, 2).Value = IIf(params = "", "(none)", params)
.Cells(5, 1).Value = "SQL (formatted)"
.Cells(6, 2).Value = sqlFmt ' ← 本文はB6に
.Columns("A:A").ColumnWidth = 25
.Columns("B:B").ColumnWidth = OPT_SQL_COL_WIDTH
.Columns("B:B").WrapText = True
.Columns("B:B").VerticalAlignment = -4160 ' xlVAlignTop
End With
' 🎨 エディタ風シンタックスカラー（別サブ）
If OPT_ENABLE_SYNTAX_COLOR Then
On Error Resume Next ' 部分書式で稀に遅い/失敗するケースを吸収
ColorizeSqlEditorStyle ws.Cells(6, 2)
On Error GoTo ErrHandler
End If
' 📎 TOCに追記（ハイパーリンク）
AppendTOC toc, name, ws.Name
added = added + 1
SysCmd acSysCmdUpdateMeter, added
NextLoop:
Next i
' 空シート削除（"Sheet*"）
On Error Resume Next
Dim s As Object
For Each s In xlBook.Sheets
If s.Name Like "Sheet*" Then s.Delete
Next s
On Error GoTo ErrHandler
' 💾 保存
xlBook.SaveAs filePath
xlBook.Close SaveChanges:=False
xlApp.Quit
SysCmd acSysCmdClearStatus
If errLog.Count > 0 Then
MsgBox "一部のクエリでエラーがありました。" & vbCrLf & _
"保存先: " & filePath & vbCrLf & vbCrLf & JoinErrors(errLog), vbExclamation
Else
MsgBox "クエリのSQLを整形し、Excelに出力しました！" & vbCrLf & "保存先: " & filePath, vbInformation
End If
Exit Sub
ErrHandler:
SysCmd acSysCmdClearStatus
On Error Resume Next
If Not xlBook Is Nothing Then xlBook.Close False
If Not xlApp Is Nothing Then xlApp.Quit
MsgBox "処理中にエラーが発生しました: " & Err.Number & " - " & Err.Description, vbCritical
Cleanup:
End Sub
' ====== ユーティリティ／判定 ======
Private Function GetDownloadsPath() As String
Dim root As String
root = Environ$("USERPROFILE")
If Len(root) = 0 Then
GetDownloadsPath = ""
Else
GetDownloadsPath = root & "\Downloads"
End If
End Function
' 対象クエリ判定（Accessの読み取り系）
Private Function IsTargetQuery(qdf As DAO.QueryDef) As Boolean
On Error GoTo SafeNo
Dim nm As String, sqlL As String
nm = Nz(qdf.Name, "")
If Not OPT_INCLUDE_SYSTEM_QUERIES Then
If Left$(nm, 1) = "~" Or Left$(nm, 4) = "MSys" Then GoTo SafeNo
End If
sqlL = LCase$(Trim$(Nz(qdf.SQL, "")))
If Len(sqlL) = 0 Then GoTo SafeNo
If Not OPT_INCLUDE_ACTION_QUERIES Then
If InStr(sqlL, " insert ") > 0 Or Left$(sqlL, 6) = "insert" Then GoTo SafeNo
If InStr(sqlL, " update ") > 0 Or Left$(sqlL, 6) = "update" Then GoTo SafeNo
If InStr(sqlL, " delete ") > 0 Or Left$(sqlL, 6) = "delete" Then GoTo SafeNo
If InStr(sqlL, " create ") > 0 Or InStr(sqlL, " alter ") > 0 Or InStr(sqlL, " drop ") > 0 Then GoTo SafeNo
End If
If Left$(sqlL, 6) = "select" _
Or InStr(sqlL, " union ") > 0 _
Or Left$(sqlL, 9) = "transform" _
Or Left$(sqlL, 10) = "parameters" Then
IsTargetQuery = True
Exit Function
End If
SafeNo:
IsTargetQuery = False
End Function
' シート名の禁止文字・長さ・重複対応
Private Function MakeSafeUniqueSheetName(xlBook As Object, baseName As String) As String
Dim nm As String, bad As Variant, i As Long, tryNm As String, n As Long
bad = Array("/", "\", "*", "[", "]", ":", "?", Chr$(34))
nm = baseName
For i = LBound(bad) To UBound(bad)
nm = Replace$(nm, bad(i), "_")
Next
nm = Trim$(nm)
If Len(nm) = 0 Then nm = "Query"
If Len(nm) > 31 Then nm = Left$(nm, 31)
tryNm = nm: n = 1
Do While SheetExists(xlBook, tryNm)
n = n + 1
tryNm = Left$(nm, 31 - Len(CStr(n))) & CStr(n)
If n > 999 Then tryNm = Left$(nm, 27) & "_" & Format(n, "000")
Loop
MakeSafeUniqueSheetName = tryNm
End Function
Private Function SheetExists(xlBook As Object, sheetName As String) As Boolean
On Error Resume Next
SheetExists = Not xlBook.Sheets(sheetName) Is Nothing
On Error GoTo 0
End Function
' パラメータ一覧
Private Function GetQueryParametersInfo(qdf As DAO.QueryDef) As String
On Error GoTo NoParam
Dim p As DAO.Parameter, buf As String
For Each p In qdf.Parameters
buf = buf & p.Name & " (Type=" & p.Type & "); "
Next
If Len(buf) > 0 Then buf = Left$(buf, Len(buf) - 2)
GetQueryParametersInfo = buf
Exit Function
NoParam:
GetQueryParametersInfo = ""
End Function
' シート初期スタイル
Private Sub InitSheetStyle(ws As Object)
With ws.Cells
.Font.Name = OPT_SHEET_FONT_NAME
.Font.Size = OPT_SHEET_FONT_SIZE
End With
ws.Columns("A:B").HorizontalAlignment = -4131 ' xlLeft
ws.Columns("A:B").VerticalAlignment = -4160 ' xlTop
ws.Columns("A:A").ColumnWidth = 25
ws.Columns("B:B").ColumnWidth = OPT_SQL_COL_WIDTH
End Sub
' TOCヘッダ
Private Sub WriteTOCHeader(toc As Object)
With toc
InitSheetStyle toc
.Cells(1, 1).Value = "Index"
.Cells(1, 2).Value = "Query Name"
.Cells(1, 3).Value = "Sheet"
.Cells(1, 1).EntireRow.Font.Bold = True
.Columns("A:C").ColumnWidth = 40
End With
End Sub
' TOCへ追記（ハイパーリンク）
Private Sub AppendTOC(toc As Object, queryName As String, sheetName As String)
Dim r As Long
r = toc.Cells(toc.Rows.Count, 1).End(-4162).Row + 1 ' xlUp
If r < 2 Then r = 2
toc.Cells(r, 2).Value = queryName
toc.Cells(r, 3).Value = sheetName
toc.Hyperlinks.Add Anchor:=toc.Cells(r, 1), Address:="", _
SubAddress:="'" & sheetName & "'!A1", TextToDisplay:="→ " & queryName
End Sub
' エラーログ
Private Sub LogError(ByRef errLog As Collection, ByVal queryName As String, ByVal message As String)
errLog.Add "[" & queryName & "] " & message
End Sub
Private Function JoinErrors(errLog As Collection) As String
Dim i As Long, a() As String
ReDim a(1 To errLog.Count)
For i = 1 To errLog.Count
a(i) = CStr(errLog(i))
Next
JoinErrors = Join(a, vbCrLf)
End Function
' ====== SQL 整形（Access句対応・インデント付） ======
Private Function FormatSQLPretty(ByVal s As String) As String
Dim i As Long, ch As String * 1
Dim out As String, tok As String, up As String
Dim inSQ As Boolean, inDQ As Boolean
Dim depth As Long
Dim needBreakBefore As Boolean
Dim lastMainClause As String
Dim indentStr As String: indentStr = String$(OPT_INDENT_SPACES, " ")
s = Trim$(s)
s = Replace$(Replace$(Replace$(s, vbCrLf, " "), vbCr, " "), vbLf, " ")
Do While InStr(s, " ") > 0: s = Replace$(s, " ", " "): Loop
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
If ch = "'" And Not inDQ Then inSQ = Not inSQ
If ch = """" And Not inSQ Then inDQ = Not inDQ
If Not inSQ And Not inDQ Then
If ch = ")" Then
If depth > 0 Then depth = depth - 1
out = RTrim$(out) & vbCrLf & String$(depth * OPT_INDENT_SPACES, " ")
End If
End If
tok = tok & ch
If (ch = " " Or ch = "," Or ch = "(" Or ch = ")" Or i = Len(s)) Then
up = UCase$(Trim$(tok))
needBreakBefore = False
If Not inSQ And Not inDQ Then
Select Case True
Case up = "GROUP BY", up = "ORDER BY", up = "HAVING"
needBreakBefore = True: lastMainClause = up
Case up Like "*JOIN"
needBreakBefore = True
Case up = "UNION", up = "UNION ALL"
needBreakBefore = True: lastMainClause = up
Case up = "WITH OWNERACCESS OPTION"
needBreakBefore = True
Case up = "PARAMETERS", up = "TRANSFORM", up = "PIVOT", up = "IN"
needBreakBefore = True: lastMainClause = up
Case up = "SELECT", up = "FROM", up = "WHERE"
needBreakBefore = True: lastMainClause = up
Case up = "DISTINCT", up = "DISTINCTROW", Left$(up, 3) = "TOP"
needBreakBefore = False
Case up = "ON"
needBreakBefore = True
Case up = "AND", up = "OR"
If lastMainClause = "WHERE" Or lastMainClause = "HAVING" Then needBreakBefore = True
End Select
End If
If needBreakBefore Then
out = RTrim$(out)
If Len(out) > 0 Then out = out & vbCrLf
out = out & String$(depth * OPT_INDENT_SPACES, " ")
End If
out = out & Trim$(tok)
If ch = "," Then
out = out & vbCrLf & String$(depth * OPT_INDENT_SPACES, " ")
ElseIf ch = "(" Then
If Not (inSQ Or inDQ) Then depth = depth + 1
out = RTrim$(out) & vbCrLf & String$(depth * OPT_INDENT_SPACES, " ")
Else
out = out & " "
End If
tok = ""
End If
Next i
out = Trim$(out)
Do While InStr(out, vbCrLf & vbCrLf & vbCrLf) > 0
out = Replace$(out, vbCrLf & vbCrLf & vbCrLf, vbCrLf & vbCrLf)
Loop
FormatSQLPretty = out
End Function
' ====== 🎨 エディタ風シンタックスハイライト（別サブ） ======
' セル内のSQLを色分け（主要句・補助句・関数・文字列・日付・識別子・数値・演算子）
Public Sub ColorizeSqlEditorStyle(ByVal xlCell As Object)
On Error GoTo SafeExit ' 大量部分書式で稀な例外に対処（安全運転）
Dim text As String
text = CStr(xlCell.Value)
If Len(text) = 0 Then Exit Sub
Dim excl As Collection
Set excl = BuildExcludedRanges(text) ' 引用/日付/角括弧は色分けから除外
' 1) 主要句（濃い青＋太字）
Dim major As Variant
major = Array("PARAMETERS", "TRANSFORM", "PIVOT", _
"SELECT", "FROM", "WHERE", "GROUP BY", "HAVING", "ORDER BY", _
"INNER JOIN", "LEFT JOIN", "RIGHT JOIN", "JOIN", "ON", _
"UNION", "UNION ALL", "WITH OWNERACCESS OPTION")
HighlightList xlCell, text, major, excl, RGB(0, 0, 160), True, False, False
' 2) 補助キーワード（青）
Dim minor As Variant
minor = Array("DISTINCT", "DISTINCTROW", "TOP", "AS", _
"BETWEEN", "IN", "LIKE", "NOT", "IS NULL", "IS NOT NULL", _
"TRUE", "FALSE", "ALL")
HighlightList xlCell, text, minor, excl, RGB(0, 0, 192), False, False, False
' 3) 関数（紫：直後に "(" があるもの）
Dim funcs As Variant
funcs = Array( _
"SUM", "COUNT", "MIN", "MAX", "AVG", "ROUND", _
"NZ", "IIF", "SWITCH", "CHOOSE", _
"DATE", "TIME", "NOW", "DATEADD", "DATEDIFF", "DATESERIAL", "TIMESERIAL", _
"FORMAT", "LEN", "MID", "LEFT", "RIGHT", "VAL", "STR", "CSTR", "CLNG", "CDATE", "CBOOL", "ISNULL", "ABS" _
)
HighlightList xlCell, text, funcs, excl, RGB(128, 0, 128), False, False, True
' 4) 文字列リテラル（"..." と '...'）→ 緑
ColorQuotedLiterals xlCell, text, """" , RGB(0, 128, 0) ' ダブルクォート
ColorQuotedLiterals xlCell, text, "'" , RGB(0, 128, 0) ' シングルクォート
' 5) 日付リテラル（#...#）→ ティール
ColorHashDateLiterals xlCell, text, RGB(0, 128, 128)
' 6) 角括弧識別子 [Field Name] / [Table] → 茶
ColorBracketIdentifiers xlCell, text, RGB(128, 64, 0)
' 7) 数値（整数/小数/E表記）→ 橙
ColorNumbers xlCell, text, excl, RGB(255, 128, 0)
' 8) 演算子（=, <>, <=, >=, +, -, *, /, & など）→ グレー
ColorOperators xlCell, text, excl, RGB(96, 96, 96)
SafeExit:
End Sub
' === ハイライト基盤 ===
Private Sub HighlightList(ByVal xlCell As Object, ByVal text As String, _
ByVal items As Variant, ByVal excl As Collection, _
ByVal clr As Long, ByVal bold As Boolean, ByVal italic As Boolean, _
ByVal requireParenAfter As Boolean)
Dim i As Long
For i = LBound(items) To UBound(items)
HighlightOne xlCell, text, CStr(items(i)), excl, clr, bold, italic, requireParenAfter
Next
End Sub
Private Sub HighlightOne(ByVal xlCell As Object, ByVal text As String, ByVal word As String, _
ByVal excl As Collection, ByVal clr As Long, _
ByVal bold As Boolean, ByVal italic As Boolean, _
ByVal requireParenAfter As Boolean)
Dim pos As Long, kLen As Long, startAt As Long
kLen = Len(word)
startAt = 1
Do
pos = InStr(startAt, text, word, vbTextCompare)
If pos = 0 Then Exit Do
If IsWholeWord(text, pos, kLen) Then
If Not IsInsideExcluded(pos, kLen, excl) Then
If Not requireParenAfter Or HasParenAfter(text, pos + kLen) Then
With xlCell.Characters(Start:=pos, Length:=kLen).Font
.Color = clr
.Bold = bold
.Italic = italic
End With
End If
End If
End If
startAt = pos + kLen
Loop
End Sub
Private Function HasParenAfter(ByVal s As String, ByVal idx As Long) As Boolean
Dim i As Long, ch As String
For i = idx To Len(s)
ch = Mid$(s, i, 1)
If ch <> " " And ch <> vbTab Then
HasParenAfter = (ch = "(")
Exit Function
End If
Next
End Function
' --- 文字列リテラルの色付け ---
Private Sub ColorQuotedLiterals(ByVal xlCell As Object, ByVal s As String, _
ByVal quoteChar As String, ByVal clr As Long)
Dim i As Long, startPos As Long, inQ As Boolean, ch As String
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
If ch = quoteChar Then
If Not inQ Then
inQ = True: startPos = i
Else
inQ = False
xlCell.Characters(Start:=startPos, Length:=i - startPos + 1).Font.Color = clr
End If
End If
Next
End Sub
' --- #...# 日付リテラルの色付け ---
Private Sub ColorHashDateLiterals(ByVal xlCell As Object, ByVal s As String, ByVal clr As Long)
Dim i As Long, startPos As Long, inHash As Boolean, ch As String
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
If ch = "#" Then
If Not inHash Then
inHash = True: startPos = i
Else
inHash = False
xlCell.Characters(Start:=startPos, Length:=i - startPos + 1).Font.Color = clr
End If
End If
Next
End Sub
' --- [ ... ] 角括弧識別子 ---
Private Sub ColorBracketIdentifiers(ByVal xlCell As Object, ByVal s As String, ByVal clr As Long)
Dim i As Long, startPos As Long, depth As Long, ch As String
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
If ch = "[" Then
If depth = 0 Then startPos = i
depth = depth + 1
ElseIf ch = "]" Then
If depth > 0 Then
depth = depth - 1
If depth = 0 Then
xlCell.Characters(Start:=startPos, Length:=i - startPos + 1).Font.Color = clr
End If
End If
End If
Next
End Sub
' --- 数値（整数/小数/E表記） ---
Private Sub ColorNumbers(ByVal xlCell As Object, ByVal s As String, ByVal excl As Collection, ByVal clr As Long)
Dim i As Long, startPos As Long, ch As String, inNum As Boolean
For i = 1 To Len(s) + 1
If i <= Len(s) Then ch = Mid$(s, i, 1) Else ch = " "
If Not inNum Then
If ch Like "[0-9]" Then
startPos = i: inNum = True
End If
Else
If Not (ch Like "[0-9]" Or ch = "." Or ch = "E" Or ch = "e" Or ch = "+" Or ch = "-") Then
If IsWholeWord(s, startPos, i - startPos) Then
If Not IsInsideExcluded(startPos, i - startPos, excl) Then
xlCell.Characters(Start:=startPos, Length:=i - startPos).Font.Color = clr
End If
End If
inNum = False
End If
End If
Next
End Sub
' --- 演算子 ---
Private Sub ColorOperators(ByVal xlCell As Object, ByVal s As String, ByVal excl As Collection, ByVal clr As Long)
Dim i As Long, ch As String, two As String
i = 1
Do While i <= Len(s)
If i < Len(s) Then
two = Mid$(s, i, 2)
If two = "<>" Or two = "<=" Or two = ">=" Then
If Not IsInsideExcluded(i, 2, excl) Then xlCell.Characters(i, 2).Font.Color = clr
i = i + 2: GoTo ContinueLoop
End If
End If
ch = Mid$(s, i, 1)
Select Case ch
Case "=", "+", "-", "*", "/", "&", "<", ">"
If Not IsInsideExcluded(i, 1, excl) Then xlCell.Characters(i, 1).Font.Color = clr
End Select
ContinueLoop:
i = i + 1
Loop
End Sub
' --- 除外範囲の構築（文字列/日付/角括弧）---
Private Function BuildExcludedRanges(ByVal s As String) As Collection
Dim col As New Collection
Dim i As Long, ch As String * 1
Dim inSQ As Boolean, inDQ As Boolean, inHash As Boolean, inBracket As Long
Dim startPos As Long
For i = 1 To Len(s)
ch = Mid$(s, i, 1)
If Not inSQ And Not inDQ And Not inHash Then
If ch = "[" Then
If inBracket = 0 Then startPos = i
inBracket = inBracket + 1
ElseIf ch = "]" And inBracket > 0 Then
inBracket = inBracket - 1
If inBracket = 0 Then AddRange col, startPos, i - startPos + 1
End If
End If
If Not inSQ And Not inDQ And inBracket = 0 Then
If ch = "#" Then
If Not inHash Then
inHash = True: startPos = i
Else
inHash = False: AddRange col, startPos, i - startPos + 1
End If
End If
End If
If inBracket = 0 And Not inHash Then
If ch = """" And Not inSQ Then
If Not inDQ Then
inDQ = True: startPos = i
Else
inDQ = False: AddRange col, startPos, i - startPos + 1
End If
ElseIf ch = "'" And Not inDQ Then
If Not inSQ Then
inSQ = True: startPos = i
Else
inSQ = False: AddRange col, startPos, i - startPos + 1
End If
End If
End If
Next
Set BuildExcludedRanges = col
End Function
Private Sub AddRange(ByRef col As Collection, ByVal startPos As Long, ByVal length As Long)
Dim r(1 To 2) As Long
r(1) = startPos: r(2) = length
col.Add r
End Sub
Private Function IsInsideExcluded(ByVal pos As Long, ByVal length As Long, ranges As Collection) As Boolean
Dim i As Long, r() As Long, s As Long, e As Long
For i = 1 To ranges.Count
r = ranges(i)
s = r(1): e = r(1) + r(2) - 1
If pos >= s And (pos + length - 1) <= e Then
IsInsideExcluded = True
Exit Function
End If
Next
End Function
Private Function IsWholeWord(ByVal s As String, ByVal pos As Long, ByVal kLen As Long) As Boolean
Dim beforeCh As String, afterCh As String
If pos > 1 Then beforeCh = Mid$(s, pos - 1, 1) Else beforeCh = " "
If pos + kLen <= Len(s) Then afterCh = Mid$(s, pos + kLen, 1) Else afterCh = " "
If IsWordChar(beforeCh) Or IsWordChar(afterCh) Then
IsWholeWord = False
Else
IsWholeWord = True
End If
End Function
Private Function IsWordChar(ByVal ch As String) As Boolean
If ch = "_" Then IsWordChar = True: Exit Function
If ch Like "[0-9A-Za-z]" Then IsWordChar = True
End Function
🎯 出力イメージ
-
TOCシート（目次） が自動生成され、各クエリシートにジャンプできる
-
各シートには
- クエリ名
- 作成日時
- パラメータ一覧
- 整形済み SQL（色分け付き！）
が出力されます
SQL はこんな感じでエディタ風に表示されます 👇
-
SELECT / FROM / WHERE / JOIN ...→ 濃い青＋太字 -
DISTINCT / TOP / AS / IN / LIKE ...→ 青 - 集計関数や組み込み関数 (
SUM,IIF,NZ, …) → 紫 -
"文字列" / '文字列'→ 緑 -
#日付#→ ティール -
[フィールド名]→ 茶 - 数値 → 橙
- 演算子 (
=,<>,>=,+,*,&…) → グレー
⚙️ 実装のポイント
-
整形処理
Access SQL の句（SELECT,FROM,WHERE,JOIN,GROUP BY,HAVING,ORDER BY,UNION ALL,TRANSFORM,PIVOT,PARAMETERSなど）を認識して改行＆インデント。 -
色付け処理
Excel のRange.Characters(...).Font.Colorを駆使して、セル内の部分文字列だけ書式変更。
→ まるで SQL Editor の Syntax Highlight のように見える 🎨
🚀 導入方法
- Access を開いて Alt+F11 で VBA エディタを開く
- 「挿入 → 標準モジュール」で新しいモジュールを作成
- 下記コードをまるごと貼り付け
-
ExportAllQuerySQLsを実行
すると、C:\Users\<あなたのユーザー名>\Downloads に
QuerySQLExport_yyyymmdd_hhnnss.xlsx が出力されます ✅
💻 ソースコード全文
（ここに最終版のモジュール全文をそのまま貼り付け）
🙌 まとめ
- Access クエリの SQL を 整形＋色分けして Excel にエクスポートできるツールを作った
- TOCシート付きでクエリごとにジャンプ可能
- 色分けで SQLエディタ並みの可読性 を確保
業務で「Access の SQL をレビューしたい」「複雑クエリをドキュメント化したい」ときに便利だと思います！
もし「この句も整形したい」「この関数も色分けしたい」などあれば、簡単にカスタマイズできます 🔧
#MicrosoftAccess #VBA #Excel #SQL #整形 #Qiita初投稿