Outlookmail固定フォルダに自動保存編

🧑‍🏫 ケンタと先生のVBA教室：固定フォルダに自動保存編

〜お宝メールを狙い撃ち！秘密のフォルダへ爆速お引越し大作戦〜

---

先生：「よしケンタ、コードを送ってくれてありがとうな！今回は、君がOutlookで『あの人のメール、テキストで残したいねん！』って言ったのを、パソコンくんが裏で一瞬で片付ける魔法の指示書や！」

👦ケンタ：「先生、これ英語ばっかりで呪文みたいやけど、上から順番に何が起きてるの？まず最初の savePath = "C:\メール履歴\" ってところは？」

🤠先生：「そこはな、パソコンくんに**『お宝（メール）をしまう秘密の基地はここやで！』**って住所を教えてるんや。しかもその下が優秀でな、もしパソコンの中にそのフォルダがなかったら、パソコンくんが『お、基地がないやんけ！作ったろ！』って、スコップ持って自動でフォルダを掘り起こしてくれるんやで！」

👦ケンタ：「へぇー、勝手に部屋を作ってくれるんや！で、その次の InputBox ってやつで、画面にポップアップが出るわけやな？」

🤠先生：「大正解！画面に『誰のメール探す？』って手紙が出てくるから、そこに相手の名前とかアドレスを打ち込む。もし何も入れずにキャンセルしたら、パソコンくんは『なんや、やらへんのかい！』ってズッコケて、安全に仕事をサボる（終了する）ようになってんねん」

👦ケンタ：「あはは、サボるんや（数行飛ばして）。あ、真ん中あたりに For Each item In folder.Items ってある！出たな、ループ！」

🤠先生：「おう、大ボスの登場や！ここからパソコンくんがダッシュで受信トレイに走り込んで、メールを1通ずつ上からめくっていくんや。**『これ、ケンタが言うてた人のメールか？違う！次！これか？あ、これや！』**ってな」

👦ケンタ：「あ！その見つけたあとのところで、Replace ってのがいっぱい並んでるけど、これ何？めちゃくちゃしつこいねんけど！」

🤠先生：「ガハハ！これはな、メールのタイトルに『/』とか『:』みたいな、パソコンのファイル名に使ったらアカン禁止文字が入ってたときに、パソコンくんが『これジャマやから消しといたろ！』って消しゴムで消しまくってる処理や。これがないとエラーで爆発（フリーズ）してまうから、超大事な優しさチェックなんやで」

👦ケンタ：「なるほど、爆発防止の消しゴムか！じゃあ、その下の mail.Attachments.Count > 0 ってのは？」

🤠先生：「そこがケンタのリクエスト通りや！メールに書類（添付ファイル）がくっついてるかジロジロ見て、**『おっ、書類つきやんけ！頭に●マークをプレゼントしたろ！』**って、ファイル名に●をペタッと貼る判定をしてるんやな」

👦ケンタ：「ほんまや、ちゃんと●がつく！で、最後に Print #fileNum ってところで、ノート（テキストファイル）に書き写してるん？」

🤠先生：「せや！指定された秘密のフォルダの中に、新しくテキストファイルを作って、**『【日付】はいついつ、【タイトル】はこれ、中身の【メール内容】はこれ！』**って、サラサラサラーッと猛スピードで書き写して、最後にファイルをパタンと閉じる（Close）んや！」

👦ケンタ：「すごっ！それを、頼んだ人のメールが見つかるたびに、何回でも繰り返すんやな！」

🤠先生：「その通り！全部のメールをチェックし終わったら、最後に**『◯件のメールを保存したで！ドヤァ！』**って画面に完了の報告（MsgBox）を出して、ハッピーエンドや！」

👦ケンタ：「ワォ！英語の呪文やと思ってたけど、パソコンくんが優しく部屋を作って、消しゴムで文字を消して、●をつけて書き写してくれてる様子がめっちゃ目に浮かんだわ！」

 

Sub ExportEmailToFixedFolder()
    Dim outlookApp As Outlook.Application
    Dim ns As Outlook.NameSpace
    Dim folder As Outlook.MAPIFolder
    Dim item As Object
    Dim mail As Outlook.MailItem
    Dim targetSender As String
    Dim savePath As String
    Dim filePath As String
    Dim cleanedSubject As String
    Dim fileName As String
    Dim attachMarker As String
    Dim fileNum As Integer
    Dim matchCount As Integer
    Dim fso As Object
    
    ' ==== 【重要】ここに保存したいフォルダのパスを入力してください ====
    ' ※末尾には必ず「\」を付けてください
    savePath = "C:\メール履歴\"
    ' ==================================================================
    
    ' フォルダが存在するか確認し、なければ自動作成する
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(savePath) Then
        On Error Resume Next
        fso.CreateFolder(savePath)
        On Error GoTo 0
        ' 作成に失敗した場合の安全対策
        If Not fso.FolderExists(savePath) Then
            MsgBox "指定されたフォルダ 「" & savePath & "」 が存在せず、作成もできませんでした。パスを確認してください。", vbCritical
            Exit Sub
        End If
    End If
    
    ' ポップアップで抽出したい相手を入力させる
    targetSender = InputBox("抽出したい相手の「メールアドレス」または「名前」を入力してください。", "差出人の指定")
    
    ' キャンセルボタンが押されたか、何も入力されなかった場合は終了
    If Trim(targetSender) = "" Then
        MsgBox "処理をキャンセルしました。", vbExclamation
        Exit Sub
    End If
    
    Set outlookApp = New Outlook.Application
    Set ns = outlookApp.GetNamespace("MAPI")
    
    ' 現在開いているフォルダーを対象にする
    Set folder = outlookApp.ActiveExplorer.CurrentFolder
    
    matchCount = 0
    
    ' フォルダー内のアイテムをループ処理
    For Each item In folder.Items
        If TypeOf item Is MailItem Then
            Set mail = item
            
            ' 差出人の判定
            If InStr(mail.SenderEmailAddress, targetSender) > 0 Or InStr(mail.SenderName, targetSender) > 0 Then
                
                matchCount = matchCount + 1
                
                ' 件名からファイル名に使えない禁止文字（\ / : * ? " < > |）を削除
                cleanedSubject = mail.Subject
                cleanedSubject = Replace(cleanedSubject, "\", ""): cleanedSubject = Replace(cleanedSubject, "/", "")
                cleanedSubject = Replace(cleanedSubject, ":", ""): cleanedSubject = Replace(cleanedSubject, "*", "")
                cleanedSubject = Replace(cleanedSubject, "?", ""): cleanedSubject = Replace(cleanedSubject, """", "")
                cleanedSubject = Replace(cleanedSubject, "<", ""): cleanedSubject = Replace(cleanedSubject, ">", "")
                cleanedSubject = Replace(cleanedSubject, "|", "")
                
                ' 添付ファイルの有無をチェック（あれば ●、なければ 空白）
                If mail.Attachments.Count > 0 Then
                    attachMarker = "●"
                Else
                    attachMarker = ""
                End If
                
                ' ファイル名を作成（差出人名_●件名_年月.txt）
                fileName = mail.SenderName & "_" & attachMarker & cleanedSubject & "_" & Format(mail.ReceivedTime, "yyyymm") & ".txt"
                filePath = savePath & fileName
                
                ' 個別のテキストファイルを開いて書き込み
                fileNum = FreeFile
                Open filePath For Output As #fileNum
                
                Print #fileNum, "【日付】 " & mail.ReceivedTime
                Print #fileNum, "【タイトル】 " & mail.Subject
                Print #fileNum, "【メール内容】"
                Print #fileNum, mail.Body
                
                Close #fileNum
            End If
        End If
    Next item
    
    ' 結果の通知
    If matchCount > 0 Then
        MsgBox matchCount & " 件のメールを 「" & savePath & "」 に保存しました！", vbInformation
    Else
        MsgBox "該当するメールが見つかりませんでした。", vbExclamation
    End If
End Sub

 

年月日指定版

Sub ExportEmailToFixedFolder2()
    Dim outlookApp As Outlook.Application
    Dim ns As Outlook.NameSpace
    Dim folder As Outlook.MAPIFolder
    Dim item As Object
    Dim mail As Outlook.MailItem
    Dim targetSender As String
    Dim startDateInput As String, endDateInput As String
    Dim startDate As Date, endDate As Date
    Dim savePath As String
    Dim filePath As String
    Dim cleanedSubject As String
    Dim fileName As String
    Dim attachMarker As String
    Dim fileNum As Integer
    Dim matchCount As Integer
    Dim fso As Object
    
    ' ==== 【重要】ここに保存したいフォルダのパスを入力してください ====
    ' ※末尾には必ず「\」を付けてください
    savePath = "C:\メール履歴\"
    ' ==================================================================
    
    ' フォルダが存在するか確認し、なければ自動作成する
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(savePath) Then
        On Error Resume Next
        fso.CreateFolder(savePath)
        On Error GoTo 0
        ' 作成に失敗した場合の安全対策
        If Not fso.FolderExists(savePath) Then
            MsgBox "指定されたフォルダ 「" & savePath & "」 が存在せず、作成もできませんでした。パスを確認してください。", vbCritical
            Exit Sub
        End If
    End If
    
    ' ポップアップで抽出したい相手を入力させる
    targetSender = InputBox("抽出したい相手の「メールアドレス」または「名前」を入力してください。", "差出人の指定")
    If Trim(targetSender) = "" Then
        MsgBox "処理をキャンセルしました。", vbExclamation
        Exit Sub
    End If
    
    ' 【変更】開始日の入力（初期値は今日の日付）
    startDateInput = InputBox("抽出する【開始日】を入力してください。" & vbCrLf & "(例: 2026/01/01)", "開始日の指定", Format(Date, "yyyy/mm/dd"))
    If Trim(startDateInput) = "" Then MsgBox "処理をキャンセルしました。", vbExclamation: Exit Sub
    If Not IsDate(startDateInput) Then
        MsgBox "正しい日付を入力してください。処理を終了します。", vbCritical
        Exit Sub
    End If
    ' 開始日の「00:00:00」として設定
    startDate = CDate(startDateInput)
    
    ' 【変更】終了日の入力（初期値は今日の日付）
    endDateInput = InputBox("抽出する【終了日】を入力してください。" & vbCrLf & "(例: 2026/01/31)", "終了日の指定", Format(Date, "yyyy/mm/dd"))
    If Trim(endDateInput) = "" Then MsgBox "処理をキャンセルしました。", vbExclamation: Exit Sub
    If Not IsDate(endDateInput) Then
        MsgBox "正しい日付を入力してください。処理を終了します。", vbCritical
        Exit Sub
    End If
    ' 終了日の「23:59:59」まで含めるために、翌日の00:00:00未満という条件で判定します
    endDate = DateAdd("d", 1, CDate(endDateInput))
    
    Set outlookApp = New Outlook.Application
    Set ns = outlookApp.GetNamespace("MAPI")
    
    ' 現在開いているフォルダーを対象にする
    Set folder = outlookApp.ActiveExplorer.CurrentFolder
    
    matchCount = 0
    
    ' フォルダー内のアイテムをループ処理
    For Each item In folder.Items
        If TypeOf item Is MailItem Then
            Set mail = item
            
            ' 差出人の判定 ＋ 受信日時の判定（開始日0:00以上、かつ終了日の翌日0:00未満）
            If (InStr(mail.SenderEmailAddress, targetSender) > 0 Or InStr(mail.SenderName, targetSender) > 0) And _
               (mail.ReceivedTime >= startDate And mail.ReceivedTime < endDate) Then
                
                matchCount = matchCount + 1
                
                ' 件名からファイル名に使えない禁止文字（\ / : * ? " < > |）を削除
                cleanedSubject = mail.Subject
                cleanedSubject = Replace(cleanedSubject, "\", ""): cleanedSubject = Replace(cleanedSubject, "/", "")
                cleanedSubject = Replace(cleanedSubject, ":", ""): cleanedSubject = Replace(cleanedSubject, "*", "")
                cleanedSubject = Replace(cleanedSubject, "?", ""): cleanedSubject = Replace(cleanedSubject, """", "")
                cleanedSubject = Replace(cleanedSubject, "<", ""): cleanedSubject = Replace(cleanedSubject, ">", "")
                cleanedSubject = Replace(cleanedSubject, "|", "")
                
                ' 添付ファイルの有無をチェック（あれば ●、なければ 空白）
                If mail.Attachments.Count > 0 Then
                    attachMarker = "●"
                Else
                    attachMarker = ""
                End If
                
                ' ファイル名を作成（差出人名_●件名_年月.txt）
                fileName = mail.SenderName & "_" & attachMarker & cleanedSubject & "_" & Format(mail.ReceivedTime, "yyyymm") & ".txt"
                filePath = savePath & fileName
                
                ' 個別のテキストファイルを開いて書き込み
                fileNum = FreeFile
                Open filePath For Output As #fileNum
                
                Print #fileNum, "【日付】 " & mail.ReceivedTime
                Print #fileNum, "【タイトル】 " & mail.Subject
                Print #fileNum, "【メール内容】"
                Print #fileNum, mail.Body
                
                Close #fileNum
            End If
        End If
    Next item
    
    ' 結果の通知
    If matchCount > 0 Then
        MsgBox matchCount & " 件のメールを 「" & savePath & "」 に保存しました！", vbInformation
    Else
        MsgBox "該当するメールが見つかりませんでした。", vbExclamation
    End If
End Sub

比較チェック転記

🧑‍🏫 ケンタと先生のVBA教室：2つの合言葉で書き換え編

👦ケンタ： 先生！後半のコード送ったよ！今回はどんな大仕事をしてるの？

🤠先生： おう、お疲れさん！今回はな、前半で選んだ「拠点aaa」か「拠点bbb」の情報を使って、2つのExcelファイルを裏で同時に開いて、パズルみたいにデータをガッチャンコさせてるんや。

👦ケンタ： 2つのファイル？どうやって見比べてるの？

🤠先生： まず、1つ目のファイル（チェック元）のX列を上から順番に見ていく。そこに「〇〇設定可能」って書いてあったら、その文字を「合言葉」にするんや。
で、2つ目の本番ファイル（転記先）の「B列の文字」と「C列の文字」をガッチャンコと合体させて、さっきの合言葉とぴったり一致するかを調べるんや。

👦ケンタ： へぇー！「B列＋C列」の合体技と、X列を見比べてるんやね。もし一致したらどうするの？

🤠先生： 一致したら、本番ファイルのAF列に「abcにより、20260607準備中」みたいに、今日の日付が入ったメモをドカンと書き込むんや！

👦ケンタ： すごい！見つけたら自動でメモを残してくれるんや。じゃあ、処理が終わったらファイルを閉じて終わり？

🤠先生： そう。本番ファイルを自動で上書き保存して、チェック用ファイルは何も変えずにそのまま閉じる。……はずなんやけどな、ケンタ。ファイルの片付けをしてる最後のここを見てみぃ。

Set wsMaster = White

👦ケンタ： あれ？「White（ホワイト：白）」になってる！

🤠先生： そうやねん！本当は使い終わったデータを空っぽ（リセット）にするために「Nothing（ナッシング）」って書かなあかんのに、なぜか「White」って書いてあるんや。このままだと、パソコンが「Whiteって何やねん！」って怒って、最後の最後でエラーを出して止まってまうで！

👦ケンタ： ほんまや！お片付けの直前で怒られるのは嫌やなぁ。ここを「Nothing」に変えれば完璧やね！

Option Explicit

Sub ExtractDataAndWriteZColumn_DoubleKey()
    Dim wbSource As Workbook, wsSource As Worksheet
    Dim lastRowSource As Long, i As Long
    Dim keyValX As String
    Dim todayStr As String
    
    ' 選択用の変数
    Dim searchKeyword As String
    
    ' ファイル選択用の変数
    Dim fd As Object
    Dim excelFilePath As String
    
    ' 別Excelファイル（転記先：ファイル名2）をチェックするための変数
    Dim wbMaster As Workbook, wsMaster As Worksheet
    Dim masterFilePath As String, lastRowMaster As Long, j As Long
    Dim masterCombineKey As String
    
    ' ========================================================
    ' [ユーザー設定エリア] ※公開時はここだけ共有すればOKです
    ' ========================================================
    ' 1. 各拠点の「別名」を設定します（ポップアップの選択肢や案内文に使われます）
    Const ALIAS_拠点1 As String = "拠点aaa" ' ★拠点1の実際の別名を入力
    Const ALIAS_拠点2 As String = "拠点bbb" ' ★拠点2の実際の別名を入力
    
    ' 2. 転記先（ファイル名2）の実際の「ファイル名」をここで指定します
    Const MASTER_FILE_拠点1 As String = "拠点aaaData.xlsx" ' ★拠点1の実際のファイル名を入力
    Const MASTER_FILE_拠点2 As String = "拠点bbbData.xlsx" ' ★拠点2の実際のファイル名を入力
    
    ' 3. 転記先（ファイル名2）の実際の「シート名」をここで指定します
    Const MASTER_SHEET_拠点1 As String = "シート名1" ' ★拠点1の転記先シート名を入力
    Const MASTER_SHEET_拠点2 As String = "シート名2" ' ★拠点2の転記先シート名を入力
    
    ' ★追加：4. 転記元（ファイル名1）の実際の「シート名」をここで指定します
    Const SOURCE_SHEET_拠点1 As String = "Sheet1"    ' ★拠点1のチェック元シート名を入力
    Const SOURCE_SHEET_拠点2 As String = "Sheet1"    ' ★拠点2のチェック元シート名を入力
    
    ' 5. 転記先（ファイル名2：マスター側）の共通フォルダパス
    Dim targetFolder2 As String
    targetFolder2 = "Z:\Work\【信頼できる場所_Excel】\基Data\"
    
    ' 6. 各ファイルの列定義
    ' 【転記先（ファイル名2）側】
    Const MASTER_KEY_B_COL As String = "B"  ' マスター側のKEY1（B列）
    Const MASTER_KEY_C_COL As String = "C"  ' マスター側のKEY2（C列）
    Const MASTER_AF_COL    As String = "AF" ' 日付を書き込むAF列
    
    ' 【チェック元（ファイル名1）側】
    Const EXCEL_KEY_X_COL  As String = "X"  ' 比較基準となるX列
    ' ========================================================
    
    ' 汎用化処理：マクロを実行した人のデスクトップ内にある「別フォルダ」のパスを自動算出
    Dim wsh As Object, targetFolder As String
    Set wsh = CreateObject("WScript.Shell")
    targetFolder = wsh.SpecialFolders("Desktop") & "\別フォルダ\"
    Set wsh = Nothing
    
    ' 1. 最初にどちらの拠点かを数字で選択するポップアップを表示
    Dim promptMsg As String, inputVal As String
    promptMsg = "どちらのデータを処理しますか？" & vbCrLf & vbCrLf & _
                "【1を入力】：" & ALIAS_拠点1 & vbCrLf & _
                "【2を入力】：" & ALIAS_拠点2
                
    inputVal = InputBox(promptMsg, "処理対象の選択", "1")
    
    ' 入力値に応じた切り替え判定（転記先・転記元のパスとシート名を決定）
    ' ★変更：設定エリアで指定したすべてのシート名・ファイル名が自動連動します
    Dim actualFileName As String, actualSheetName As String, sourceSheetName As String
    If inputVal = "1" Then
        searchKeyword = ALIAS_拠点1
        actualFileName = MASTER_FILE_拠点1
        actualSheetName = MASTER_SHEET_拠点1
        sourceSheetName = SOURCE_SHEET_拠点1
        masterFilePath = targetFolder2 & MASTER_FILE_拠点1
    ElseIf inputVal = "2" Then
        searchKeyword = ALIAS_拠点2
        actualFileName = MASTER_FILE_拠点2
        actualSheetName = MASTER_SHEET_拠点2
        sourceSheetName = SOURCE_SHEET_拠点2
        masterFilePath = targetFolder2 & MASTER_FILE_拠点2
    Else
        MsgBox "処理を中止します。", vbInformation
        Exit Sub
    End If
    
    ' 2. チェック元（ファイル名1）をフォルダから選んでもらう画面を表示
    Set fd = Application.FileDialog(3) ' msoFileDialogFilePicker
    
    With fd
        .Title = "【チェック元（ファイル名1）】のExcelファイルを選択してください"
        .InitialFileName = targetFolder & "*" & searchKeyword & "*.xl*" ' 「別フォルダ」内の対象ファイルを自動絞り込み
        .AllowMultiSelect = False
        
        .Filters.Clear
        .Filters.Add "Excelファイル", "*.xlsx; *.xls; *.xlsm"
        
        If .Show = -1 Then
            excelFilePath = .SelectedItems(1) ' 選ばれたファイルのパスを取得
        Else
            MsgBox "ファイルが選択されなかったため、処理を中止します。", vbExclamation
            Exit Sub
        End If
    End With
    
    ' 画面更新と警告メッセージを停止して高速化＆自動化
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 本日の日付から「abcにより、yyyymmdd準備中」の文字列を作成
    todayStr = "abcにより、" & Format(Date, "yyyymmdd") & "準備中"
    
    ' 3. チェック元（ファイル名1）を自動で開く
    Set wbSource = Workbooks.Open(excelFilePath)
    
    ' ★追加：指定された転記元のシート名を開きます（シート名エラー対策付き）
    On Error Resume Next
    Set wsSource = wbSource.Sheets(sourceSheetName)
    If Err.Number <> 0 Then
        wbSource.Close SaveChanges:=False
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        MsgBox "選択したチェック元ファイルに「" & sourceSheetName & "」というシートが見つかりませんでした。", vbCritical, "エラー"
        Exit Sub
    End If
    On Error GoTo 0
    
    ' チェック元の最終行を取得（X列を基準に判定）
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, EXCEL_KEY_X_COL).End(xlUp).Row
    
    ' 4. 転記先（ファイル名2：マスターファイル）を背景で自動的に開く（書き込み可）
    On Error Resume Next
    Set wbMaster = Workbooks.Open(Filename:=masterFilePath, ReadOnly:=False)
    If Err.Number <> 0 Then
        wbSource.Close SaveChanges:=False ' 先に開いたチェック元を閉じる
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        MsgBox "転記先（ファイル名2）の「" & actualFileName & "」を開けませんでした。" & vbCrLf & _
               "ネットワークパスやファイル名を確認してください。", vbCritical, "エラー"
        Exit Sub
    End If
    
    ' 指定された転記先のシート名を開きます（シート名エラー対策付き）
    Set wsMaster = wbMaster.Sheets(actualSheetName)
    If Err.Number <> 0 Then
        wbMaster.Close SaveChanges:=False
        wbSource.Close SaveChanges:=False
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        MsgBox "転記先ファイルに「" & actualSheetName & "」というシートが見つかりませんでした。", vbCritical, "エラー"
        Exit Sub
    End If
    On Error GoTo 0
    
    lastRowMaster = wsMaster.Cells(wsMaster.Rows.Count, MASTER_KEY_B_COL).End(xlUp).Row
    
    ' 5. チェック元（ファイル名1）の2行目から最終行までループ処理
    For i = 2 To lastRowSource
        
        ' チェック元ファイル側の「X列」の値をKEYとして取得（前後の余計な空白をカット）
        keyValX = Trim(wsSource.Cells(i, EXCEL_KEY_X_COL).Value)
        
        ' KEYが空白でなく、かつX列に「設定可能」という文字が含まれている場合のみチェック
        If keyValX <> "" And InStr(keyValX, "設定可能") > 0 Then
            
            ' 転記先（ファイル名2）の全行を走査して合致チェック
            For j = 2 To lastRowMaster
                
                ' 転記先側のB列とC列（000等を保持）を合わせたKEYを作成
                masterCombineKey = Trim(wsMaster.Cells(j, MASTER_KEY_B_COL).Value) & _
                                   Trim(wsMaster.Cells(j, MASTER_KEY_C_COL).Text)
                
                ' チェック元のX列の値 と 転記先の結合KEY が合致するか判定
                If keyValX = masterCombineKey Then
                    ' 合致したら、転記先（ファイル名2）のAF列に日付文字を直接書き込み（転記）
                    wsMaster.Cells(j, MASTER_AF_COL).Value = todayStr
                End If
            Next j
            
        End If
        
    Next i
    
    ' 6. 後片付けとファイルの保存
    ' 転記先（ファイル名2）は更新されたので上書き保存して閉じる
    wbMaster.Close SaveChanges:=True
    Set wsMaster = White
    Set wbMaster = Nothing
    
    ' チェック元（ファイル名1）は中身を見ただけなので保存せずに閉じる
    wbSource.Close SaveChanges:=False
    Set wsSource = Nothing
    Set wbSource = Nothing
    
    ' 停止していた機能を再開
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    ' 完了通知
    MsgBox "データの転記および【" & actualFileName & "】のAF列の更新が完了しました！", vbInformation
End Sub

Access照合＆Z列更新

🧐 そもそも何が問題やったん？

先生：ななぁ、前のコードな、実は「やり方」がめっちゃ要領悪かったんや。

生徒：え、動いてたやん！何があかんの？

先生：たとえるならな、算数のドリルをやってて、「1問解くたびに、職員室の先生のところまで行って『これで合ってますか？』って聞きに行く」みたいな状態やったんや。

生徒：いや、めんどくさっ！！ 職員室と教室、何往復すんねん！ 足パンパンなるわ！

先生：せやろ？ 行数が1000行あったら、1000回もAccess（職員室）に聞きに行ってたから、パソコンが「もうしんどいわ…」ってフリーズしそうになってたんや。

---

🚀 新しいコードはどう変えたん？

先生：そこでや！ 新しいマクロでは、やり方をガラッと変えた。
まず、最初にマクロくん（生徒）が職員室に行って、「先生！今日の問題の答え（Accessのデータ）、1枚の紙に全部メモさせて！」って言うて、最初に全部カンペを作っちゃうねん。

生徒：お、頭いいな。

先生：で、教室（Excel）に戻って、そのカンペを見ながら「えーっと、B列とC列の組み合わせは…あ、カンペに載ってるわ！じゃあZ列に『準備中』って書こ！」って、自分の机の上だけで完結させるようにしたんや。

生徒：なるほどな！ いちいち職員室に行かんでいいから、一瞬でドリルが終わるわけや！

---

🛠️ 具体的に何をしてるの？（3つのステップ）

① 職員室でカンペ作り（Dictionary機能）

• 先生：Accessから「項目2がABCから始まるやつ」のB列とC列のペアを、一気にガバッと持ってきて、パソコンのメモリっていう「脳みそ」の中に記憶（Dictionary）させたんや。

② 教室でスピード採点（ループ処理）

• 先生：Excelのシートを2行目から下に向かって順番に見ていく。D列が空っぽで、B列とC列に文字が入ってたら、さっきの脳みその中のカンペと見比べる。

③ 合格ならハンコを押す

• 先生：カンペに「同じペア」が載ってたら、合格！ってことで、Z列に「2026xxxx準備中」っていう本日の日付スタンプをポンッと押す。

---

⚠️ もしものときのお守り（エラートラップ）

生徒：なぁ先生、もし途中でパソコンがバグったり、ファイルが見つからへんかったらどうなるん？

先生：そこもバッチリや！ 前のコードやと、エラーが出たらExcelが画面真っ白のままフリーズしてもうてた。
今回はな、「もし途中でコケたら、とりあえず開いたファイルを全部そっと閉じて、画面を元に戻して『エラー出たで！』って優しく教えてな」っていう、安全装置（お守り）を入れておいたんや。

生徒：気が利くやん。

---

先生：…というわけで、やってる中身（結果）は全く一緒やけど、「最初にカンペを作ってから一気に解く」ようにしたから、めちゃくちゃ足が速くなったマクロ君に変身したってわけや！

生徒：なるほどなー。要領よくサボる方法を覚えたってことやな。

先生：言い方悪いわ！「効率化」って言うて！

---

もし、この新しいカンペ方式のコードで実際に動かしてみて、うまく「準備中」が書き込まれたか教えてな！うまく動かんかったら、またいつでも相談に乗るで！

 

 

Sub ExtractDataAndWriteZColumn_DoubleKey()
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim lastRowSource As Long, i As Long
    Dim keyValB As String, keyValC As String
    Dim todayStr As String
    
    ' DB接続用の変数 (ADO)
    Dim cn As Object ' ADODB.Connection
    Dim rs As Object ' ADODB.Recordset
    Dim dbPath As String, sqlStr As String
    
    ' ========================================================
    ' [ユーザー設定エリア] ※お使いの環境に合わせて必ず書き換えてください
    ' ========================================================
    ' 1. 別フォルダにある指定ファイルの「フルパス」と「シート名」
    Dim excelFilePath As String
    excelFilePath = "C:\Users\Username\Desktop\別フォルダ\指定ファイル.xlsx" ' ★実際のパスへ
    Const EXCEL_SHEET_NAME As String = "シート名"                             ' ★実際のシート名へ
    
    ' 2. Accessファイルの「フルパス」
    dbPath = "C:\Users\Username\Documents\SampleDB.accdb"                   ' ★実際のパスへ
    
    ' 3. Access側のクエリ名と列名（フィールド名）
    Const ACCESS_QUERY_NAME As String = "Q_既存のクエリ名" ' Accessにあるクエリの名前
    Const ACCESS_KEY_B_FIELD As String = "KEY_B列名"       ' ★クエリ内の「B列」に対応する列名
    Const ACCESS_KEY_C_FIELD As String = "KEY_C列名"       ' ★クエリ内の「C列」に対応する列名
    Const ACCESS_ITEM2_FIELD As String = "項目2"           ' クエリ内の項目2の列名
    
    ' 4. Excel側の列定義（列のアルファベットを指定）
    Const EXCEL_KEY_B_COL As String = "B" ' ★KEYの1つ目（B列）
    Const EXCEL_KEY_C_COL As String = "C" ' ★KEYの2つ目（C列）
    Const EXCEL_ITEM1_COL As String = "D" ' ★項目1が入っている列（※B・C列がKEYになったのでD列に変更しています。実際の列に合わせてください）
    Const EXCEL_Z_COL     As String = "Z" ' 結果を書き込むZ列
    ' ========================================================
    
    ' 画面更新と警告メッセージを停止して高速化＆自動化
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 本日の日付から「yyyymmdd準備中」の文字列を作成
    todayStr = Format(Date, "yyyymmdd") & "準備中"
    
    ' 1. 別フォルダの指定ファイルを自動で開く
    Set wbSource = Workbooks.Open(excelFilePath)
    Set wsSource = wbSource.Sheets(EXCEL_SHEET_NAME)
    
    ' Excelシートの最終行を取得（B列を基準に最終行を判定）
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, EXCEL_KEY_B_COL).End(xlUp).Row
    
    ' 2. Accessデータベースへの接続を開始
    Set cn = CreateObject("ADODB.Connection")
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";"
    
    ' 3. 2行目から最終行まで1行ずつループ処理
    For i = 2 To lastRowSource
        
        ' 【条件1】Excelの項目1の列が「空白」である場合のみ処理
        If wsSource.Cells(i, EXCEL_ITEM1_COL).Value = "" Then
            
            ' ExcelのB列とC列のKEY値をそれぞれ取得（前後の余計な空白をカット）
            keyValB = Trim(wsSource.Cells(i, EXCEL_KEY_B_COL).Value)
            
            ' 両方のKEYが空白でない場合のみ、Access側を確認
            If keyValB <> "" Then
                keyValC = Trim(wsSource.Cells(i, EXCEL_KEY_C_COL).Value)
                
                ' 【条件2】Accessの既存クエリから、B列KEYとC列KEYが両方一致し、項目2が「NNNから始まる」データをカウント
                ' ※B列・C列のKEYがともに文字列型（テキスト型）である場合の記述です
                sqlStr = "SELECT COUNT(*) FROM [" & ACCESS_QUERY_NAME & "] " & _
                         "WHERE [" & ACCESS_KEY_B_FIELD & "] = '" & keyValB & "' " & _
                         "AND [" & ACCESS_KEY_C_FIELD & "] = '" & keyValC & "' " & _
                         "AND [" & ACCESS_ITEM2_FIELD & "] LIKE 'ABC%';"
                
                ' SQLを実行して件数を取得
                Set rs = cn.Execute(sqlStr)
                
                ' 条件に合致するデータが1件以上存在した場合
                If rs(0).Value > 0 Then
                    ' ExcelのZ列に「yyyymmdd準備中」を書き込み
                    wsSource.Cells(i, EXCEL_Z_COL).Value = todayStr
                End If
                
                ' レコードセットを閉じる
                rs.Close
            End If
            
        End If
    Next i
    
    ' 4. 後片付けとファイルの保存
    ' データベース接続を閉じる
    cn.Close
    Set rs = Nothing
    Set cn = Nothing
    
    ' 指定ファイルを上書き保存して閉じる
    wbSource.Close SaveChanges:=True
    
    ' 停止していた機能を再開
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    ' 完了通知
    MsgBox "指定ファイルデータの確認（ダブルKEY対応）およびZ列の更新が完了しました！", vbInformation
End Sub

Variant型で「000」を維持するための必須コード

🧑‍🏫 ケンタと先生のVBA教室

🤠先生： ケンタ、Excelで「001」って打ったのに、勝手に「1」に消されてイラッとしたことないか？

👦ケンタ： あるある！「00」どこ行ったん？！ってなる！

🤠先生： やろ？このプログラムはな、その「00」が消えへんように守りながら、別のシートにコピーする魔法の呪文なんや。

👦ケンタ： へぇー！どうやってるの？

🤠先生： まず、1つ目のここや！

dataArray = wsA.Range("A1:C10").Value

🤠先生： これはな、「シートA」のマス目にあるデータを、特製の「透明なバケツ（dataArray）」に一気にドサッと入れたんや。このバケツの中では、まだ「001」のまま形がキープされてんねん。

👦ケンタ： まだセーフなんやね。

🤠先生： そう。でもな、これをそのまま「シートB」に流し込んだら、Excelが気を利かせて「数字の1」にしよるねん。そこで、2つ目のこれが超大事なんや！

wsB.Range("A1:C10").NumberFormatLocal = "@"

🤠先生： 貼り付ける予定のマス目に、あらかじめ「ここは文字しか入らへん部屋ですよー！数字に変えたら怒るでー！」っていう「文字専用スタンプ（@）」をポンッと押しておくんや。

👦ケンタ： なるほど！部屋をガードしたんやな！

🤠先生： その通り！仕上げがこれや！

wsB.Range("A1:C10").Value = dataArray

🤠先生： ガードされた部屋に、さっきのバケツのデータをドボドボドボーって流し込む。これで「001」が「1」に変身せんと、そのままきれいにコピーできるわけや！

👦ケンタ： Excelの先回りをブロックしたんやね！先生、完璧やん！

Sub CopyWithVariant()
    Dim wsA As Worksheet: Set wsA = Sheets("A")
    Dim wsB As Worksheet: Set wsB = Sheets("B")
    
    ' 1. セルから一括で読み込む（Variant型になる）
    Dim dataArray As Variant
    dataArray = wsA.Range("A1:C10").Value ' 元々セルが「001」なら文字列として入る
    
    ' 2. 【超重要】貼り付け先（Bシート）のセルをあらかじめ文字列型にする
    ' これがないと、Variantからセルに移る瞬間に「1」に化けます
    wsB.Range("A1:C10").NumberFormatLocal = "@"
    
    ' 3. 貼り付け
    wsB.Range("A1:C10").Value = dataArray
End Sub

条件付きデータマージ（行挿入型）

🧑‍🏫 ケンタと先生のVBA教室：合体（マージ）編

👦ケンタ： 先生！今度のコード、なんかめちゃくちゃ長くて難しそうやん…！

🤠先生： びびらんでええよ！やってることは**「超スゴい宝探しとパズル」**や。
「検索」シートのA列とB列に、探したい「合言葉（KEY）」が書いてあるやろ？

👦ケンタ： うん、書いてある！

🤠先生： このプログラムはな、その合言葉を持って、「Data1」から「Data5」までの5つの部屋（シート）を順番に回って、お宝データを探しに行くねん。

👦ケンタ： へぇー！5つの部屋を全部見るんや。見つけたらどうするの？

🤠先生： 見つけたら「検索」シートのC列からN列に、見つけたデータを横に並べていくんや。ただ、ここでパズルみたいな超重要ルールが2つある。

👦ケンタ： ルール？

🤠先生： 1つ目はな、もし部屋の中に「BC」っていう名前のお宝があったら、その**「BCの中身」が同じデータ同士だけを1行にまとめる（マージする）**。もし「BCの中身」が違ってたら、別々の行に新しく並べるっていうルールや。

👦ケンタ： フムフム、同じ仲間は合体させて、違うやつは分けてあげるんやね。

🤠先生： さすがケンタ、理解が早いわ！
で、2つ目のルールはな、5つの部屋をどれだけ探しても**「お宝が1つも見つからへんかった合言葉」があったら、諦めて横に「Dataなし」**ってスタンプを押してあげるんや。

👦ケンタ： 迷子にならんように「おらへんかったでー」って記録残すんやな。

🤠先生： その通り！で、最後、集めたお宝を「検索」シートにドサッと書き出すとき、前の授業でやった**「アレ」**を使ってんねん。ほら、コードの最後の方に書いてあるやろ？

.Range("B2:B" & .Rows.Count).NumberFormatLocal = "@"

👦ケンタ： あ！これ、前教えてもらった**「文字専用スタンプ」**や！

🤠先生： 大正解！B列の合言葉が「005」とかやったときに、Excelが勝手に「5」に変換してまわんように、あらかじめ部屋をガードしてからデータを書き込んでるんや。これで「00」が消えずに完璧な表が完成するわけ。

👦ケンタ： 部屋を順番に探して、同じ仲間は合体させて、最後は文字型でキレイに守って貼り付ける…完璧な流れやん！

Option Explicit

Sub MultiSheetDataMerge_Final_StringB()
    Dim wsSearch As Worksheet, wsData As Worksheet
    Dim targetSheets As Variant, sheetName As Variant
    Dim lastRowSearch As Long, lastRowData As Long
    Dim targetHeaders As Variant, resultList As Object
    Dim searchKeyArray As Variant, sourceData As Variant
    Dim i As Long, j As Long, rowIdx As Long, colIdx As Long
    Dim sKeyA As String, sKeyB As String, headerName As String
    Dim colMap As Object, keyRecords As Object
    Dim record As Variant, isPlaced As Boolean

    ' 高速化設定
    With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: End With

    Set wsSearch = ThisWorkbook.Sheets("検索")
    targetSheets = Array("Data1", "Data2", "Data3", "Data4", "Data5")
    ' 検索シートの見出し(C1:N1)を取得
    targetHeaders = wsSearch.Range("C1:N1").Value
    
    lastRowSearch = wsSearch.Cells(wsSearch.Rows.Count, "A").End(xlUp).Row
    If lastRowSearch < 2 Then Exit Sub
    
    ' A・B列を読み込み。B列も念のため文字列として扱う
    searchKeyArray = wsSearch.Range("A2:B" & lastRowSearch).Value

    Set resultList = CreateObject("System.Collections.ArrayList")

    ' 1. 「BC」列の相対位置を特定
    Dim bcPosInItems As Integer: bcPosInItems = 0
    For j = 1 To 12
        If targetHeaders(1, j) = "BC" Then bcPosInItems = j: Exit For
    Next j

    ' 2. 検索シートの各KEY行について処理
    For i = 1 To UBound(searchKeyArray, 1)
        sKeyA = CStr(searchKeyArray(i, 1))
        sKeyB = CStr(searchKeyArray(i, 2)) ' B列を文字列として取得
        Set keyRecords = CreateObject("System.Collections.ArrayList")

        For Each sheetName In targetSheets
            If SheetExists(CStr(sheetName)) Then
                Set wsData = Sheets(sheetName)
                Set colMap = CreateObject("Scripting.Dictionary")
                
                ' 各データシートの見出し列位置を把握
                For j = 1 To wsData.Cells(1, wsData.Columns.Count).End(xlToLeft).Column
                    colMap(CStr(wsData.Cells(1, j).Value)) = j
                Next j
                
                lastRowData = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
                If lastRowData >= 2 Then
                    ' A列を起点にデータを取得
                    sourceData = wsData.Range("A1").CurrentRegion.Value
                    
                    For rowIdx = 2 To UBound(sourceData, 1)
                        ' KEY（A列・B列）が一致（B列は文字列比較）
                        If CStr(sourceData(rowIdx, 1)) = sKeyA And CStr(sourceData(rowIdx, 2)) = sKeyB Then
                            
                            ' C1:N1に対応するデータを抽出
                            Dim currentData As Variant: ReDim currentData(1 To 12)
                            Dim currentBCVal As String: currentBCVal = ""
                            Dim hasBCColumn As Boolean: hasBCColumn = colMap.Exists("BC")
                            
                            For j = 1 To 12
                                headerName = CStr(targetHeaders(1, j))
                                If colMap.Exists(headerName) Then
                                    currentData(j) = CStr(sourceData(rowIdx, colMap(headerName)))
                                    If headerName = "BC" Then currentBCVal = currentData(j)
                                Else
                                    currentData(j) = ""
                                End If
                            Next j
                            
                            ' 既存行へのマージ判定
                            isPlaced = False
                            For j = 0 To keyRecords.Count - 1
                                record = keyRecords.Item(j)
                                Dim existingBCVal As String: existingBCVal = ""
                                If bcPosInItems > 0 Then existingBCVal = CStr(record(bcPosInItems))
                                
                                ' BCの値が一致、またはBC列がない、または既存行のBCが空ならマージ
                                If Not hasBCColumn Or (existingBCVal = currentBCVal) Or (existingBCVal = "" And currentBCVal <> "") Then
                                    For colIdx = 1 To 12
                                        If currentData(colIdx) <> "" Then record(colIdx) = currentData(colIdx)
                                    Next colIdx
                                    keyRecords.Item(j) = record
                                    isPlaced = True: Exit For
                                End If
                            Next j
                            
                            ' BCが違う場合は新規行として追加
                            If Not isPlaced Then keyRecords.Add currentData
                        End If
                    Next rowIdx
                End If
            End If
        Next sheetName
        
        ' --- 結果集約 ---
        If keyRecords.Count = 0 Then
            Dim noDataRow As Variant: ReDim noDataRow(1 To 14)
            noDataRow(1) = sKeyA: noDataRow(2) = sKeyB
            For j = 3 To 14: noDataRow(j) = "Dataなし": Next j
            resultList.Add noDataRow
        Else
            For j = 0 To keyRecords.Count - 1
                Dim finalRow As Variant: ReDim finalRow(1 To 14)
                finalRow(1) = sKeyA: finalRow(2) = sKeyB
                record = keyRecords.Item(j)
                For colIdx = 1 To 12: finalRow(colIdx + 2) = record(colIdx): Next colIdx
                resultList.Add finalRow
            Next j
        End If
    Next i

    ' 3. 書き出し（B列の書式設定と一括出力）
    With wsSearch
        .Range("A2:N" & .Rows.Count).ClearContents
        ' B列を文字列形式に設定
        .Range("B2:B" & .Rows.Count).NumberFormatLocal = "@"
        
        If resultList.Count > 0 Then
            Dim outArray As Variant: ReDim outArray(1 To resultList.Count, 1 To 14)
            For i = 0 To resultList.Count - 1
                record = resultList.Item(i)
                For j = 1 To 14: outArray(i + 1, j) = record(j): Next j
            Next i
            .Range("A2").Resize(UBound(outArray, 1), 14).Value = outArray
        End If
    End With

    With Application: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True: End With
    MsgBox "B列を文字列として保持し、転記が完了しました。", vbInformation
End Sub

Function SheetExists(n As String) As Boolean
    On Error Resume Next: SheetExists = Not Sheets(n) Is Nothing: On Error GoTo 0
End Function

Oracle対応版：データ抽出マクロ

🧑‍🏫 ケンタと先生のVBA教室：データベース接続編

👦ケンタ： 先生！また新しいコードや！今度は「Oracle（オラクル）」って書いてあるけど、これなぁに？

🤠先生： おっ、ええところに気づいたな！Oracleっていうのはな、学校の図書室の何百倍もの本（データ）が詰まった、「超巨大なデータの大倉庫」のことや。

👦ケンタ： へぇー！そんなすごい倉庫から、どうやってデータを持ってくるの？

🤠先生： まず、このコードの最初の方で、その倉庫に入るための「秘密のパスワード（IDやパスワード）」を入力して、倉庫の扉をガチャッと開けるんや。

👦ケンタ： セキュリティバッチリやな。で、中に入ったらどうするの？

🤠先生： ケンタは、Excelのシートの中に「テキストボックス」っていう文字を書く四角い箱があるの知ってるか？

👦ケンタ： 知ってる！文字入力できるやつやろ？

🤠先生： そう！そこに「〇〇のデータをください」っていう倉庫への命令書（SQL）を書いておくねん。このプログラムは、その命令書を読み込んで、倉庫に持っていくんやけど……ここで「お掃除ロボット」が発動する。

If InStr(currentLine, "--") > 0 Then ...

👦ケンタ： お掃除ロボット？何をお掃除するの？

🤠先生： 命令書の中に書かれた「※これはメモです」みたいな、倉庫の人には関係ない「ただのメモ書き（コメント行）」を、自動でキレイに消し去ってくれるんや。さらに、Excel用の言葉を、Oracle倉庫の人が読める言葉に自動で翻訳（置換）までしてくれるんやで。

👦ケンタ： 賢い！気が利くロボットやなぁ。

🤠先生： やろ？そうしてキレイになった命令書を倉庫の受付にポイッと渡すと、倉庫の人が「はい、どうぞ！」ってお宝データをまとめて返してくれる。

👦ケンタ： 返ってきたデータはどうなるの？

🤠先生： 最後の仕上げがこれや！

ws.Cells(2, 1).CopyFromRecordset rs

🤠先生： 返ってきた大量のデータを、Excelのシートにドババババーッ！って一瞬で敷き詰めるんや。おまけに、文字がはみ出さへんように、マスの幅も自動でピッタリ（AutoFit）に整えてくれる。

👦ケンタ： 命令書をキレイにして、倉庫からデータを持ってきて、Excelにピッタリ並べる。全部自動でやってくれるなんて最高やん！

Sub GetOracleData_Pro_Version()
    Dim conn As Object, rs As Object
    Dim strSQL As String, rawSQL As String
    Dim strConn As String, ws As Worksheet
    Dim lines() As String, i As Long, cleanSQL As String

    ' --- 設定エリア ---
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' Oracle接続情報（環境に合わせて書き換えてください）
    ' TNS名(Data Source)、ユーザーID、パスワードを指定します
    strConn = "Provider=OraOLEDB.Oracle;Data Source=Your_TNS_Name;" & _
              "User Id=Your_UserID;Password=Your_Password;"
    ' ------------------

    ' 1. テキストボックスからSQL読み込み
    On Error Resume Next
    rawSQL = ws.Shapes("テキスト ボックス 1").TextFrame2.TextRange.Characters.Text
    On Error GoTo 0

    If Trim(rawSQL) = "" Then
        MsgBox "テキストボックスにSQLを入力してください。", vbExclamation
        Exit Sub
    End If

    ' 2. 【お掃除機能】コメント行（--）の除去
    lines = Split(rawSQL, vbCr)
    cleanSQL = ""
    For i = 0 To UBound(lines)
        Dim currentLine As String
        currentLine = Replace(lines(i), vbLf, "")
        If InStr(currentLine, "--") > 0 Then
            currentLine = Left(currentLine, InStr(currentLine, "--") - 1)
        End If
        If Trim(currentLine) <> "" Then
            cleanSQL = cleanSQL & " " & currentLine
        End If
    Next i

    ' 3. 【Oracle用変換】
    strSQL = cleanSQL
    ' Access用の「#」をOracle用の「'」に自動変換
    strSQL = Replace(strSQL, "#", "'")
    ' Access用の「*」をOracle用の「%」に自動変換
    strSQL = Replace(strSQL, "*", "%")
    ' 末尾の「;」があるとOracleはエラーになる場合が多いので除去
    strSQL = Trim(strSQL)
    If Right(strSQL, 1) = ";" Then strSQL = Left(strSQL, Len(strSQL) - 1)

    ' 4. 接続と実行
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    On Error Resume Next
    conn.Open strConn
    
    If Err.Number <> 0 Then
        MsgBox "Oracle接続エラー: " & Err.Description, vbCritical
        Exit Sub
    End If

    rs.Open strSQL, conn, 3, 1
    
    If Err.Number <> 0 Then
        MsgBox "Oracle SQL実行エラーです。" & vbCrLf & _
               "内容: " & Err.Description, vbCritical
        GoTo CleanUp
    End If
    On Error GoTo 0

    ' 5. 書き出し
    Application.ScreenUpdating = False
    ws.Cells.Clear
    
    For i = 0 To rs.Fields.Count - 1
        ws.Cells(1, i + 1).Value = rs.Fields(i).Name
    Next i

    If Not rs.EOF Then
        ws.Cells(2, 1).CopyFromRecordset rs
        ws.Columns.AutoFit
    Else
        MsgBox "データは見つかりませんでした。", vbInformation
    End If

CleanUp:
    If rs.State <> 0 Then rs.Close
    conn.Close
    Set rs = Nothing: Set conn = Nothing
    Application.ScreenUpdating = True
End Sub

改修版：SQL行頭カンマ整形ツール（Access用）

🧑‍🏫 ケンタと先生のVBA教室：SQLお片付け編

👦ケンタ： 先生！今回のコード、最初のところに「Excel」じゃなくて「DAO.Database」とか書いてある！これって何？

🤠先生： お、さすがケンタ！今回はな、Excelじゃなくて**「Accessくんの画面の中」で直接動かすプログラム**なんや。

👦ケンタ： え、Accessの中で動かすの？何のために？

🤠先生： Accessでデータを探す命令書（SQLクエリ）を作ってると、勝手に1行に長〜くつながって、どこに何が書いてあるか分からん「ぐちゃぐちゃな状態」になるやろ？

👦ケンタ： あるある！横に長すぎてスクロールするのめっちゃめんどくさい！

🤠先生： やろ？このプログラムは、そんなクエリを開いた状態でボタンをポチッと押すと、一瞬で**「見やすいように改行して並べ替えてくれるお片付けロボ」**なんや。

👦ケンタ： どうやってお片付けしてるの？

🤠先生： まず、1つ目の技がこれや！

Do While InStr(strSQL, " ") > 0 ...

🤠先生： ぐちゃぐちゃな原因になってる「無駄なスペース（空白）」を、全部まとめて1つのスペースにギュッと縮めるんや。部屋に散らばったゴミを1箇所に集める感じやな。

👦ケンタ： まずは部屋をスッキリさせるんやね。

🤠先生： そう。そのあとがこのロボットの1番の得意技！**「キーワードでの改行」**や！

strSQL = Replace(strSQL, " FROM ", vbCrLf & "FROM ")

🤠先生： 「SELECT（これ持ってきて）」「FROM（この倉庫から）」「WHERE（この条件で）」っていう、SQLの大事なキーワードを見つけたら、その手前で自動的に「改行（Enter）」をポンポンポンッ！と入れていくんや。

👦ケンタ： おぉー！段落分けしてくれるんや！

🤠先生： そう。さらにこのコード、めちゃくちゃマニアックでな。

strSQL = Replace(strSQL, "," & vbCrLf & " ", vbCrLf & ", ")

🤠先生： 持ってくるデータの項目が多いとき、普通の人は「リンゴ, [改行] ミカン」って書くやろ？でも、プロのエンジニアはな、あとで項目を消したり増やしたりしやすいように、**「[改行] , リンゴ [改行] , ミカン」みたいに、行の最初にカンマ（,）を持ってくる「行頭カンマ形式」**っていうキレイな書き方をするねん。このコードは、そのプロの見た目に自動で大変身させてくれるんや！

👦ケンタ： すげえ！一瞬でプロっぽい見やすい書類に書き換えてくれるんやね！

🤠先生： その通り！最後は、Accessの命令の締めくくりである「分末のセミコロン（;）」をピシッと付け直して、クエリを上書き保存して終了や。

Function FormatActiveQuerySQL()
    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim qName As String
    Dim strSQL As String

    ' 1. 対象クエリの取得
    qName = Application.CurrentObjectName
    If qName = "" Or Application.CurrentObjectType <> acQuery Then
        MsgBox "整形したいクエリを開くか、選択してください。", vbExclamation
        Exit Function
    End If

    Set db = CurrentDb
    Set qdf = db.QueryDefs(qName)

    ' 2. SQLの整形ロジック
    strSQL = qdf.SQL
    
    ' 一旦、改行や余計なスペースを掃除して1行にする
    strSQL = Replace(strSQL, vbCrLf, " ")
    strSQL = Replace(strSQL, vbCr, " ")
    strSQL = Replace(strSQL, vbLf, " ")
    Do While InStr(strSQL, "  ") > 0 ' 連続スペースを1つに
        strSQL = Replace(strSQL, "  ", " ")
    Loop
    strSQL = Trim(strSQL)
    ' 末尾のセミコロンは一旦除去（最後に付け直すため）
    If Right(strSQL, 1) = ";" Then strSQL = Left(strSQL, Len(strSQL) - 1)

    ' 3. キーワードでの改行と「行頭カンマ」の適用
    strSQL = Replace(strSQL, "SELECT ", "SELECT" & vbCrLf & "  ")
    ' カンマの後にスペースがある場合も考慮して「, 」を「改行 + カンマ」に置換
    strSQL = Replace(strSQL, ", ", "," & vbCrLf & "  ")
    ' 念のためスペースなしのカンマも置換（すでに行われた置換はスルーされます）
    strSQL = Replace(strSQL, ",", "," & vbCrLf & "  ")
    
    ' 各句の前に改行を入れる
    strSQL = Replace(strSQL, " FROM ", vbCrLf & "FROM ")
    strSQL = Replace(strSQL, " WHERE ", vbCrLf & "WHERE ")
    strSQL = Replace(strSQL, " LEFT JOIN ", vbCrLf & "LEFT JOIN ")
    strSQL = Replace(strSQL, " INNER JOIN ", vbCrLf & "INNER JOIN ")
    strSQL = Replace(strSQL, " GROUP BY ", vbCrLf & "GROUP BY ")
    strSQL = Replace(strSQL, " ORDER BY ", vbCrLf & "ORDER BY ")
    strSQL = Replace(strSQL, " UNION ", vbCrLf & "UNION " & vbCrLf)

    ' 4. 行頭カンマの見た目を整える（カンマを改行の直後に持ってくる調整）
    ' 置換の結果「, [改行]」となったものを「[改行], 」に微調整
    strSQL = Replace(strSQL, "," & vbCrLf & "  ", vbCrLf & ", ")

    ' 5. 書き戻し（文末セミコロン付与）
    qdf.SQL = strSQL & ";"

    MsgBox "クエリ「" & qName & "」を『行頭カンマ形式』で整形しました。", vbInformation

    Set qdf = Nothing
    Set db = Nothing
End Function

改修版：コメントアウト対応・Accessデータ抽出マクロ

🧑‍🏫 ケンタと先生のVBA教室：Access接続編

👦ケンタ： 先生！今回のコード、こないだの「Oracle」のやつとそっくりやん！使い回し？

🤠先生： 目のつけどころがシャープやね、ケンタ！そう、流れはほとんど一緒や。でも今回は行く大倉庫が「Oracle」じゃなくて、Microsoft生まれの「Access（アクセス）大倉庫」に変わったんや。

👦ケンタ： 倉庫が変わったら、何が変わるの？

🤠先生： まず、最初の方にある倉庫の場所の指定の仕方が変わる。

dbPath = "C:\path\to\your\database.accdb"

🤠先生： Oracleのときはインターネットの先にある巨大サーバーに繋いだけど、Accessは自分のパソコンの中（Cドライブとか）にある「.accdb」っていう名前のファイルを直接ガチャッと開けに行くんや。

👦ケンタ： なるほど、自分のパソコンの中にある倉庫なんやね。

🤠先生： そういうこと。で、今回もテキストボックスの命令書を読み込んで「お掃除ロボット」がメモ書きを消してくれるんやけど、注目は3つ目の「自動翻訳（置換）」の内容や！

strSQL = Replace(strSQL, "*", "%")

👦ケンタ： あ！「＊」を「％」に変えてる！これ、前回のOracleのときと逆じゃない？

🤠先生： よく見てるなぁ！実はな、ExcelやAccessの画面で普通に「あいまい検索（〜を含むデータ）」をするときは「*」を使うやろ？

👦ケンタ： うん、「ケンタ」って書いたら、ケンタを含む文字を探せるやつ！

🤠先生： せやねん。でも、VBAのプログラム（ADO）を使ってAccess倉庫に命令するときは、なぜか「*」じゃなくて「%」っていう別のマークに変えんと、倉庫の人が「えっ、何これ？」ってフリーズしてしまうんや。さらに、1文字検索の「?」も「_」に翻訳してあげる必要がある。

👦ケンタ： えー！Accessの倉庫なのに、プログラムから話しかけるときは別の言葉（%や_）じゃないと通じへんの？めんどくさ！

🤠先生： ははは、ほんまそれな。だからこのプログラムが、テキストボックスに人間が書いた「*」や「?」を、倉庫の人が理解できる「%」や「_」に自動でコッソリ翻訳してくれてるわけや。

👦ケンタ： なるほど！人間が普通に書いた命令を、プログラムが裏でAccess専用に翻訳してくれてるんやね。

🤠先生： その通り！翻訳された命令を渡せば、あとは前回と同じ。データをドババババーッ！とExcelシートに敷き詰めて、マスの幅もピッタリ（AutoFit）にして終了や！

 

Sub GetAccessData_Pro_Version()
    Dim conn As Object, rs As Object
    Dim strSQL As String, rawSQL As String
    Dim dbPath As String, ws As Worksheet
    Dim lines() As String, i As Long, cleanSQL As String

    ' --- 設定エリア ---
    Set ws = ThisWorkbook.Sheets("Sheet1")
    dbPath = "C:\path\to\your\database.accdb" ' ★実際のパスに変更
    ' ------------------

    ' 1. テキストボックスからSQLを読み込む
    On Error Resume Next
    rawSQL = ws.Shapes("テキスト ボックス 1").TextFrame2.TextRange.Characters.Text
    On Error GoTo 0

    If Trim(rawSQL) = "" Then
        MsgBox "テキストボックスにSQLを入力してください。", vbExclamation
        Exit Sub
    End If

    ' 2. 【お掃除機能】コメント行（--）の除去と整形
    lines = Split(rawSQL, vbCr) ' 改行で分割
    cleanSQL = ""
    For i = 0 To UBound(lines)
        Dim currentLine As String
        currentLine = Replace(lines(i), vbLf, "") ' 残った改行コードを除去
        
        ' 「--」があれば、それ以降をカット
        If InStr(currentLine, "--") > 0 Then
            currentLine = Left(currentLine, InStr(currentLine, "--") - 1)
        End If
        
        ' 空行でなければ連結（前後にスペースをいれて結合ミスを防ぐ）
        If Trim(currentLine) <> "" Then
            cleanSQL = cleanSQL & " " & currentLine
        End If
    Next i

    ' 3. 【自動変換】Access記号をVBA(ADO)用に変換
    strSQL = cleanSQL
    strSQL = Replace(strSQL, "*", "%")   ' あいまい検索
    strSQL = Replace(strSQL, "＊", "%")
    strSQL = Replace(strSQL, "?", "_")   ' 1文字検索
    strSQL = Replace(strSQL, "？", "_")

    ' 4. ADO接続と実行
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    On Error Resume Next
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";"
    
    If Err.Number <> 0 Then
        MsgBox "DB接続エラー: " & Err.Description, vbCritical
        Exit Sub
    End If

    rs.Open strSQL, conn, 3, 1
    
    If Err.Number <> 0 Then
        MsgBox "SQL実行エラーです。構文や項目名を確認してください。" & vbCrLf & _
               "内容: " & Err.Description, vbCritical
        GoTo CleanUp
    End If
    On Error GoTo 0

    ' 5. 書き出し処理
    Application.ScreenUpdating = False
    ws.Cells.Clear
    
    ' 見出し書き出し
    For i = 0 To rs.Fields.Count - 1
        ws.Cells(1, i + 1).Value = rs.Fields(i).Name
    Next i

    ' データ流し込み
    If Not rs.EOF Then
        ws.Cells(2, 1).CopyFromRecordset rs
        ws.Columns.AutoFit
    Else
        MsgBox "条件に一致するデータは見つかりませんでした。", vbInformation
    End If

CleanUp:
    If rs.State <> 0 Then rs.Close
    conn.Close
    Set rs = Nothing: Set conn = Nothing
    Application.ScreenUpdating = True
End Sub

ExcelVBAからAccessデータ抽出(AccessSQLプレビューコード流用版)

🧑‍🏫 ケンタと先生のVBA教室：Accessスマート編

👦ケンタ： 先生！このコード、さっきの「Access Pro版」と名前が似てるけど、何が違うの？

🤠先生： お、いい質問や！今回はな、前のやつから「メモ書き（コメント）を消すお掃除機能」をなくして、コードを短くシンプルにしたんや。だから「スマート」っていう名前がついてるねん。

👦ケンタ： そっか！命令書（SQL）にメモ書きをしない人なら、これで十分ってことやね。

🤠先生： その通り！やってることは3つのステップで超シンプルや。

1. テキストボックスの命令書を読み込む
2. 「*」を「%」にコッソリ自動翻訳する
3. 自分のパソコンにあるAccess倉庫（dbPath = "C:サンプルData.accdb"）を開けて、データを取ってくる

👦ケンタ： ほんまや、すっきりしてて分かりやすい！

🤠先生： やろ？でもな、ケンタ。このコードをこのまま動かそうとすると、実は1箇所だけ「バグ（間違い）」があって動かへんねん。先生、見つけてもうたわ。

👦ケンタ： ええっ！？どこどこ？

🤠先生： ここや！設定エリアのここを見てみぃ。

dbPath = "C:サンプルData.accdb"

👦ケンタ： あ！「C:」のあとに、あの斜めの線（￥マーク）が入ってへん！

🤠先生： 大正解！これやとパソコンが「そんな場所ありません！」って怒って、ステップ3の倉庫を開けるところでエラー（接続失敗）になってまうねん。正しくは "C:\サンプルData.accdb"（環境によっては C:\サンプル\Data.accdb）って書かんとあかん。

👦ケンタ： 惜しい！そこだけ直せば、あとはバッチリデータをドババババーッ！って持ってきて、マスの幅もピッタリ（AutoFit）にしてくれるんやね！

Sub GetAccessData_Smart()
    Dim conn As Object
    Dim rs As Object
    Dim strConnection As String
    Dim strSQL As String
    Dim ws As Worksheet
    Dim dbPath As String

    ' --- 設定エリア ---
    Set ws = ThisWorkbook.Sheets("Sheet1") ' 実行するシート名
    dbPath = "C:サンプルData.accdb" ' Accessファイルのパス
    ' ------------------

    ' 1. テキストボックスからSQLを読み込む
    On Error Resume Next
    strSQL = ws.Shapes("テキスト ボックス 1").TextFrame2.TextRange.Characters.Text
    On Error GoTo 0

    If Trim(strSQL) = "" Then
        MsgBox "テキストボックスにSQLを入力してください。", vbExclamation
        Exit Sub
    End If

    ' 2. AccessのSQLをVBA(ADO)で動くように自動変換
    ' 「*」を「%」に、「?」を「_」に置換
    strSQL = Replace(strSQL, "*", "%")
    strSQL = Replace(strSQL, "＊", "%")
    strSQL = Replace(strSQL, "?", "_")
    strSQL = Replace(strSQL, "？", "_")

    ' 3. ADO接続
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";"
    
    On Error Resume Next
    conn.Open strConnection
    
    If Err.Number <> 0 Then
        MsgBox "データベースへの接続に失敗しました。" & vbCrLf & Err.Description, vbCritical
        Exit Sub
    End If

    ' 4. SQLの実行
    rs.Open strSQL, conn, 3, 1 ' 3:Static, 1:ReadOnly
    
    If Err.Number <> 0 Then
        MsgBox "SQLの実行に失敗しました。構文を確認してください。" & vbCrLf & _
               "エラー内容: " & Err.Description, vbCritical
        conn.Close
        Exit Sub
    End If
    On Error GoTo 0

    ' 5. シートへ書き出し
    Application.ScreenUpdating = False
    
    ' データ部のみクリア（A1のヘッダーを残す場合は Range("A2:Z10000").ClearContents ）
    ws.Cells.Clear

    ' フィールド名（見出し）の書き出し
    Dim i As Integer
    For i = 0 To rs.Fields.Count - 1
        ws.Cells(1, i + 1).Value = rs.Fields(i).Name
    Next i

    ' データの流し込み
    If Not rs.EOF Then
        ws.Cells(2, 1).CopyFromRecordset rs
        ws.Columns.AutoFit ' 列幅を自動調整
    Else
        MsgBox "抽出結果は0件でした。", vbInformation
    End If

    ' 6. 後片付け
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
    
    Application.ScreenUpdating = True
    MsgBox "データの抽出が完了しました。", vbInformation
End Sub

SQL to VBA Converter

🧑‍🏫 ケンタと先生のVBA教室：改行と出力の進化編

👦ケンタ： 先生！また同じ名前のコードやけど、コメントに「ここが重要！」とか書いてある！

🤠先生： お、鋭いな！まず1つ目の大進化は、そのコメントが書いてある「改行コードの統一」の場所や。

rawSql = Replace(rawSql, vbCrLf, vbLf)
rawSql = Replace(rawSql, vbCr, vbLf)

🤠先生： 実はな、パソコンの世界では「改行」の裏の仕組みが、Windows、Mac、スマホとかで全部バラバラなんや。別のパソコンから持ってきたSQLやと、プログラムが改行を見つけられずにフリーズすることがある。

👦ケンタ： ええっ、見た目は同じ改行なのに、パソコンによって中身が違うの？！

🤠先生： そうやねん。だからこのコードは、「どんなパソコンから持ってきた改行でも、いったん全部同じ種類（vbLf）に統一してから1行ずつに切り分ける」っていう超親切なガードを入れたんや。これでどんなSQLが来てもエラーにならへん！

👦ケンタ： どんな見た目の改行でもドンと来い！ってことやね。他にはどこが変わったの？

🤠先生： 2つ目の違いは、最後の「フッター（仕上げ）」の部分や。前のコードはExcelのシートにドバッと書き出してたけど、今回はここを見てみぃ。

Debug.Print rs.Fields(0).Value

👦ケンタ： 「Debug.Print」ってなぁに？シートに書かへんの？

🤠先生： これはな、Excelのシートを汚さずに、VBAの裏画面（イミディエイトウィンドウ）に「ひとまず結果をテスト表示してな！」っていう命令なんや。

👦ケンタ： へぇー！本番のシートに貼り付ける前に、ちゃんとデータが取れてるかテストできるんやね。

🤠先生： その通り！「Do While 〜 Loop」っていう呪文で、見つかったデータを上から順番に1行ずつ裏画面にメモしていく仕組みや。「改行のバグを無くして、まずは裏画面で安全にテストできるコード」に生まれ変わったわけやな！

Sub SQL_to_VBA_Converter()
    Dim shpIn As Shape, shpOut As Shape
    Dim rawSql As String, vbaCode As String
    Dim lines As Variant, i As Long
    
    Set shpIn = ActiveSheet.Shapes("テキスト ボックス 1")
    Set shpOut = ActiveSheet.Shapes("テキスト ボックス 2")
    rawSql = shpIn.TextFrame2.TextRange.Text
    If rawSql = "" Then Exit Sub

    ' --- 1. 改行コードの統一（ここが重要！） ---
    ' Windows(vbCrLf), Mac(vbCr), Unix(vbLf) どれが来ても vbCrLf に統一
    rawSql = Replace(rawSql, vbCrLf, vbLf)
    rawSql = Replace(rawSql, vbCr, vbLf)
    lines = Split(rawSql, vbLf)

    ' --- 2. Subのヘッダー ---
    vbaCode = "Sub SQLtoVBA()" & vbCrLf
    vbaCode = vbaCode & "    Dim db As Object, rs As Object, sql As String" & vbCrLf & vbCrLf
    vbaCode = vbaCode & "    Set db = CreateObject(""DAO.DBEngine.120"").OpenDatabase(""あなたのAccessパス.accdb"")" & vbCrLf & vbCrLf
    vbaCode = vbaCode & "    sql = """"" & vbCrLf

    ' --- 3. 1行ずつ確実にラップする ---
    For i = LBound(lines) To UBound(lines)
        Dim lineText As String
        lineText = Trim(lines(i))
        If lineText <> "" Then
            lineText = Replace(lineText, ";", "")
            lineText = Replace(lineText, """", """""")
            ' 1行ごとに sql = sql & "..." を完結させる
            vbaCode = vbaCode & "    sql = sql & "" " & lineText & " """ & vbCrLf
        End If
    Next i

    ' --- 4. フッター ---
    vbaCode = vbaCode & vbCrLf & "    Set rs = db.OpenRecordset(sql)" & vbCrLf
    vbaCode = vbaCode & "    Do While Not rs.EOF" & vbCrLf
    vbaCode = vbaCode & "        Debug.Print rs.Fields(0).Value" & vbCrLf
    vbaCode = vbaCode & "        rs.MoveNext" & vbCrLf
    vbaCode = vbaCode & "    Loop" & vbCrLf
    vbaCode = vbaCode & "    rs.Close: db.Close" & vbCrLf
    vbaCode = vbaCode & "    Set rs = Nothing: Set db = Nothing" & vbCrLf
    vbaCode = vbaCode & "End Sub"

    shpOut.TextFrame2.TextRange.Text = vbaCode
End Sub

データの最終行に合わせて、ひな形（テンプレート）の罫線を自動で引く

🧑‍🏫 ケンタと先生のVBA教室：罫線自動化編

👦ケンタ： 先生！今回のコードは「罫線（けいせん）」って書いてある！線を引いてくれるの？

🤠先生： そうや！データが増えたり減ったりするたびに、自分で「格子ボタン」を押して線を微調整するの、めっちゃめんどくさいやろ？

👦ケンタ： 面倒くさい！データが減ったときに、線の残骸だけが下に残るのめっちゃダサいし！

🤠先生： やろ？このプログラムはな、データの「縦の長さ（行）」と「横の長さ（列）」を毎回自動で測って、「今あるデータにだけピッタリ四角く線を引く」っていう超スマートな仕事をしてくれるんや。

👦ケンタ： へぇー！どうやってるの？

🤠先生： まず、最初の設定エリアで「ここからスタート！」っていう起点を決める。

Const START_ROW As Long = 5 （5行目から）
Const START_COL As Long = 2 （B列から）

🤠先生： で、2つ目のエリアで、その起点から下と右にレーダーを飛ばして、「データがどこまで入ってるか（最終行と最終列）」を自動計算するんや。もしデータが空っぽでも、プログラムがバグらんようにちゃんと「逆走防止（補正）」のガードまで入っとる。

👦ケンタ： ちゃんと長さを測ってから線を引くんやね。

🤠先生： そう。そして1番のポイントが、3つ目の描画処理のここや！

targetRange.Borders.LineStyle = xlNone

👦ケンタ： 「xlNone（エクセル・ノン）」？これなぁに？

🤠先生： これが、ケンタがさっき言ってたダサい残骸を消す「リセット魔法」や！新しく線を引く前に、まずはそのエリアの古い線を全部きれいに消し去るんや。

👦ケンタ： おぉー！それから新しい線を引くんやね！

🤠先生： そういうこと！まっさらにしてから、これや！

.LineStyle = xlContinuous （ふつうの実線を）
.Weight = xlThin （細い太さで）

🤠先生： 外側も内側も、細い実線でチチンプイプイのプイッ！と一瞬でキレイな格子状にしてくれるわけやな。

👦ケンタ： 古い線を消して、今のデータにピッタリ細い線を引いてくれる…これでもう表の見た目で怒られへんわ！

Sub 罫線自動化()
    ' ==========================================
    ' 1. 設定エリア（ここを変えるだけでOK）
    ' ==========================================
    Const START_ROW As Long = 5    ' 起点の行番号 (例: 5)
    Const START_COL As Long = 2    ' 起点の列番号 (例: 2 = B列)
    
    ' ==========================================
    ' 2. 実行エリア（ここから下は自動計算）
    ' ==========================================
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim lastRow As Long
    Dim lastCol As Long
    Dim targetRange As Range

    With ws
        ' 指定した起点列（START_COL）を基準に最終行を探す
        lastRow = .Cells(.Rows.Count, START_COL).End(xlUp).Row
        
        ' 指定した起点行（START_ROW）を基準に最終列を探す
        lastCol = .Cells(START_ROW, .Columns.Count).End(xlToLeft).Column

        ' データが起点より少ない場合の補正（逆走防止）
        If lastRow < START_ROW Then lastRow = START_ROW
        If lastCol < START_COL Then lastCol = START_COL

        ' 範囲を特定
        Set targetRange = .Range(.Cells(START_ROW, START_COL), .Cells(lastRow, lastCol))
        
        ' --------------------------------------
        ' 3. 描画処理
        ' --------------------------------------
        On Error Resume Next ' シート保護対策
        
        ' 以前の罫線をクリア
        targetRange.Borders.LineStyle = xlNone
        
        ' 外枠・内枠に実線を引く
        With targetRange.Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
        End With
        
        On Error GoTo 0
    End With

    ' デバッグ用（本番はコメントアウトしてOK）
    ' Debug.Print "起点(" & START_ROW & "," & START_COL & ") から " & targetRange.Address & " まで引きました"
End Sub

Excel VBA側で E列が #N/A の行を判定してスキップし、#N/A でない行だけを Accessのテーブルへ転記

生徒
先生、この
If Not IsError
って、何してるん？

先生
簡単に言うとな、
「このセル、変な値ちゃうか？」
をチェックしとるんや。

---

生徒
変な値って？

先生
#N/A みたいな、
「答え出せません」っていう印やな。

---

生徒
それが入ってたら？

先生
その行は使わへん。
何もせんと次へ行く。

---

生徒
ほな、この文はどう読むん？

 

If Not IsError(セル) Then

先生
こう読む。

「もしこのセルが、エラー ちゃう なら」

---

生徒
Not は？

先生
「ちゃう」って意味や。

---

生徒
なんでわざわざ調べるん？

先生
エラーのまま Access に渡したら、
Access が止まるからや。
せやから、ちゃんとしたデータだけ通す。

---

まとめ（先生）

• IsError → エラーかどうか調べる

• Not → ちゃう

• #N/A があった行 → スキップ

• 問題ない行だけ → Accessへ転記

これでコードの役目はバッチリや。

VBAサンプルコード（DAO使用）

Sub ExportToAccess_SkipNA()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("検索シート")

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Access接続
    Dim db As Object
    Set db = CreateObject("DAO.DBEngine.120").OpenDatabase( _
        "C:\sample\sample.accdb")

    Dim sql As String
    Dim i As Long

    For i = 2 To lastRow   ' 1行目はヘッダ想定

        ' E列が #N/A ならスキップ
        If Not IsError(ws.Cells(i, "E").Value) Then

            sql = "INSERT INTO テーブル名 (列A, 列B, 列E) VALUES (" & _
                  "'" & ws.Cells(i, "A").Value & "'," & _
                  "'" & ws.Cells(i, "B").Value & "'," & _
                  "'" & ws.Cells(i, "E").Value & "')"

            db.Execute sql

        End If

    Next i

    db.Close
    Set db = Nothing

    MsgBox "転記完了しました"

End Sub

#N/A だけを厳密に判定したい場合

If IsError(ws.Cells(i, "E").Value) Then
    If ws.Cells(i, "E").Value = CVErr(xlErrNA) Then
        ' #N/A → スキップ
    Else
        ' 他のエラー → 処理する場合
    End If
Else
    ' 正常値 → 転記
End If

名前を付けて保存ダイアログを表示して保存する

先生：「ほんなら今日は、Excelで自動で条件付きでデータ転記してCSVに保存するマクロの話やで～」

生徒：「え～、先生、難しそうやけど…」

先生：「大丈夫や！順番に見たら分かるから。まず最初にやることはな…」

生徒：「うん、なになに？」

先生：「ユーザーにExcelファイルを選んでもらうんや。ほんならそのファイルを開いて、シートAからデータを取り込むんやで」

生徒：「なるほど、選んだファイルのデータを使うんやな」

先生：「せや。次にな、条件付き転記いうのをやるねん。今回はルールがあって…」

生徒：「どんなルールなん？」

先生：「Z列に ‘●’ がある行だけを対象にしてな、F列が A やったら E列に ‘AAA’ を書くねん」

生徒：「ほうほう」

先生：「F列が B やったらな、まず E列に ‘AAA’ 書いて、そのあともう1行追加して E列に ‘BBB’ 書くねん」

生徒：「えっ、1つの行が2行になるんか！」

先生：「そうや、C の場合も同じで、まず ‘AAA’、それから ‘CCC’ って追加するんや」

生徒：「なるほど、わかってきたで」

先生：「そしたら、転記したデータはシートB（ひな形）に順番に書き込むねん。空白行は作らんように destRow って数を使うんやで」

生徒：「ふむふむ、コピーして書く感じやな」

先生：「そや。最後に、保存先のフォルダを選んでもらって、CSV形式で保存するんや。しかも UTF-8 でな、文字化けせんようにしてるんやで」

生徒：「なるほど～、だからボタン押したら自動で全部やってくれるんや！」

先生：「せやで。ほんなら、まとめると…

1. ファイル選んで開く

2. 条件付きでシートBに転記（Z列 ‘●’ & F列によって AAA/BBB/CCC）

3. 必要なら行を追加

4. CSVとして保存

っていう流れや」

生徒：「めっちゃ便利やん！自分でやるより簡単やな」

先生：「せやろ？Excel先生が全部やってくれるんやで！」

Sub 名前を付けて保存ダイアログを表示して保存する()

    Dim wbSrc As Workbook
    Dim wsSrc As Worksheet
    Dim wsTmp As Worksheet
    Dim lastRow As Long
    Dim startFolder As String
    Dim destRow As Long
    Dim i As Long
    Dim filePath As Variant
    Dim savePath As Variant
    Dim baseName As String
    Dim folderPath As String
    Dim csvPath As String
    Dim valF As String

    ' 連番用
    Dim f As String
    Dim seqNo As Long
    Dim maxSeq As Long
    Dim dateStr As String
    Dim userName As String

    '========================
    ' ユーザー名取得（Windowsログイン名）
    '========================
    userName = Environ("USERNAME")

    '========================
    ' 初期フォルダ設定
    '========================
    startFolder = ThisWorkbook.Path
    If startFolder = "" Then
        startFolder = "D:\サンプル"
    End If

    If Dir(startFolder, vbDirectory) = "" Then
        MsgBox "初期フォルダが存在しません。" & vbCrLf & startFolder, vbCritical
        Exit Sub
    End If

    '========================
    ' 元Excelファイル選択
    '========================
    ChDrive startFolder
    ChDir startFolder

    filePath = Application.GetOpenFilename( _
        "Excel ファイル (*.xlsx; *.xlsm), *.xlsx; *.xlsm", _
        1, _
        "元データブックを選択してください")

    If filePath = False Then Exit Sub

    Set wbSrc = Workbooks.Open(filePath)
    Set wsSrc = wbSrc.Sheets("シートA")
    Set wsTmp = ThisWorkbook.Sheets("ひな形")

    '========================
    ' ひな形初期化
    '========================
    wsTmp.Rows("2:" & wsTmp.Rows.Count).ClearContents

    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
    destRow = 2

    '========================
    ' 条件付き転記
    '========================
    For i = 2 To lastRow
        If wsSrc.Cells(i, "Z").Value = "●" Then

            valF = wsSrc.Cells(i, "F").Value

            Select Case valF
                Case "A"
                    wsTmp.Cells(destRow, "A").Value = wsSrc.Cells(i, "A").Value
                    wsTmp.Cells(destRow, "B").Value = wsSrc.Cells(i, "B").Value
                    wsTmp.Cells(destRow, "C").Value = "AAA"
                    destRow = destRow + 1

                Case "B"
                    wsTmp.Cells(destRow, "A").Value = wsSrc.Cells(i, "A").Value
                    wsTmp.Cells(destRow, "B").Value = wsSrc.Cells(i, "B").Value
                    wsTmp.Cells(destRow, "C").Value = "AAA"
                    destRow = destRow + 1

                    wsTmp.Cells(destRow, "A").Value = wsSrc.Cells(i, "A").Value
                    wsTmp.Cells(destRow, "B").Value = wsSrc.Cells(i, "B").Value
                    wsTmp.Cells(destRow, "C").Value = "BBB"
                    destRow = destRow + 1

                Case "C"
                    wsTmp.Cells(destRow, "A").Value = wsSrc.Cells(i, "A").Value
                    wsTmp.Cells(destRow, "B").Value = wsSrc.Cells(i, "B").Value
                    wsTmp.Cells(destRow, "C").Value = "AAA"
                    destRow = destRow + 1

                    wsTmp.Cells(destRow, "A").Value = wsSrc.Cells(i, "A").Value
                    wsTmp.Cells(destRow, "B").Value = wsSrc.Cells(i, "B").Value
                    wsTmp.Cells(destRow, "C").Value = "CCC"
                    destRow = destRow + 1
            End Select
        End If
    Next i

    wbSrc.Close SaveChanges:=False

    '========================
    ' 名前を付けて保存（ベース名取得）
    '========================
    savePath = Application.GetSaveAsFilename( _
        InitialFileName:=startFolder & "\FilteredData.csv", _
        FileFilter:="CSV ファイル (*.xlsx), *.xlsx", _
        Title:="CSVのベース名を指定してください")

    If savePath = False Then Exit Sub

    folderPath = Left(savePath, InStrRev(savePath, "\") - 1)
    baseName = Mid(savePath, InStrRev(savePath, "\") + 1)
    baseName = Left(baseName, InStrRev(baseName, ".") - 1)

    '========================
    ' 日付＋連番決定
    '========================
    dateStr = Format(Date, "yyyymmdd")
    f = Dir(folderPath & "\" & baseName & "_" & dateStr & "_" & userName & "-*.csv")

    maxSeq = 0
    Do While f <> ""
        seqNo = CLng(Mid(f, InStrRev(f, "-") + 1, 3))
        If seqNo > maxSeq Then maxSeq = seqNo
        f = Dir
    Loop

    seqNo = maxSeq + 1

    csvPath = folderPath & "\" & baseName & "_" & userName & "_" & dateStr & "-" & Format(seqNo, "000") & ".csv"

    '========================
    ' CSV保存（上書きなし）
    '========================
    wsTmp.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs fileName:=csvPath, FileFormat:=xlCSVUTF8
    ActiveWorkbook.Close SaveChanges:=False
    Application.DisplayAlerts = True

    '========================
    ' 保存後 フォルダを開く
    '========================
    Shell "explorer.exe """ & folderPath & """", vbNormalFocus

    MsgBox "CSV保存が完了しました。" & vbCrLf & csvPath, vbInformation

End Sub

ーーーーーーーーーーーーーーーーーーーーー

ーーーーーーーーーーーーーーーーーーーーー

マクロ構成（3本）

段階	ボタン	役割
①	作成ボタン	作成中データをひな形に出力
②	（手動）	日付を確認・編集
③	CSV化ボタン	そのままCSV保存

Sub 作成中データを作成する()

    Dim wbSrc As Workbook
    Dim wsSrc As Worksheet
    Dim wsTmp As Worksheet
    Dim lastRow As Long
    Dim destRow As Long
    Dim i As Long
    Dim filePath As Variant
    Dim valF As String

    filePath = Application.GetOpenFilename( _
        "Excel ファイル (*.xlsx; *.xlsm), *.xlsx; *.xlsm", , _
        "元データブックを選択してください")

    If filePath = False Then Exit Sub

    Set wbSrc = Workbooks.Open(filePath)
    Set wsSrc = wbSrc.Sheets("シートA")
    Set wsTmp = ThisWorkbook.Sheets("ひな形")

    wsTmp.Rows("2:" & wsTmp.Rows.Count).ClearContents

    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
    destRow = 2

    For i = 2 To lastRow
        If wsSrc.Cells(i, "Z").Value = "●" Then

            valF = wsSrc.Cells(i, "F").Value

            Select Case valF
                Case "A"
                    wsTmp.Cells(destRow, "A").Value = wsSrc.Cells(i, "A").Value
                    wsTmp.Cells(destRow, "B").Value = wsSrc.Cells(i, "B").Value
                    wsTmp.Cells(destRow, "C").Value = "AAA"
                    destRow = destRow + 1

                Case "B"
                    wsTmp.Cells(destRow, "A").Value = wsSrc.Cells(i, "A").Value
                    wsTmp.Cells(destRow, "B").Value = wsSrc.Cells(i, "B").Value
                    wsTmp.Cells(destRow, "C").Value = "AAA"
                    destRow = destRow + 1

                    wsTmp.Cells(destRow, "A").Value = wsSrc.Cells(i, "A").Value
                    wsTmp.Cells(destRow, "B").Value = wsSrc.Cells(i, "B").Value
                    wsTmp.Cells(destRow, "C").Value = "BBB"
                    destRow = destRow + 1

                Case "C"
                    wsTmp.Cells(destRow, "A").Value = wsSrc.Cells(i, "A").Value
                    wsTmp.Cells(destRow, "B").Value = wsSrc.Cells(i, "B").Value
                    wsTmp.Cells(destRow, "C").Value = "AAA"
                    destRow = destRow + 1

                    wsTmp.Cells(destRow, "A").Value = wsSrc.Cells(i, "A").Value
                    wsTmp.Cells(destRow, "B").Value = wsSrc.Cells(i, "B").Value
                    wsTmp.Cells(destRow, "C").Value = "CCC"
                    destRow = destRow + 1
            End Select
        End If
    Next i

    wbSrc.Close SaveChanges:=False

    wsTmp.Activate
    MsgBox "作成中データを作成しました。" & vbCrLf & _
           "日付を確認・修正後、CSV化してください。", vbInformation

End Sub

Sub CSV化して保存する()

    Dim ws As Worksheet
    Dim folderPath As String
    Dim fileName As String
    Dim csvPath As String
    Dim startFolder As String

    Set ws = ThisWorkbook.Sheets("ひな形")

    ' 保存データチェック
    If ws.Cells(ws.Rows.Count, "A").End(xlUp).Row < 2 Then
        MsgBox "保存するデータがありません。", vbExclamation
        Exit Sub
    End If

    ' 初期フォルダー（←ここを自由に指定）
    startFolder = "D:\サンプル"

    ' 存在チェック（安全対策）
    If Dir(startFolder, vbDirectory) = "" Then
        startFolder = ThisWorkbook.Path
    End If

    ' フォルダー選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "CSV保存先フォルダーを選択してください"
        .AllowMultiSelect = False
        .InitialFileName = startFolder & "\"
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems(1)
    End With

    fileName = "FilteredData.csv"
    csvPath = folderPath & "\" & fileName

    ' CSV保存
    ws.Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs csvPath, xlCSVUTF8
    ActiveWorkbook.Close False
    Application.DisplayAlerts = True

    MsgBox "CSV保存が完了しました。" & vbCrLf & csvPath, vbInformation

End Sub

ひな形を使って新規ブック作成 改修版(ヒット０件の場合の処理)

Sub ひな形を使って新規ブック作成()

    Dim srcWB As Workbook
    Dim srcSheet2 As Worksheet, srcSheet3 As Worksheet
    Dim destWB As Workbook
    Dim destSheet2 As Worksheet, destSheet3 As Worksheet
    Dim templatePath As String, outputFolder As String
    Dim newFileName As String
    Dim lastRow As Long, i As Long, destRow As Long
    Dim fileDialog As FileDialog
    Dim selectedFile As String
    
    ' ← 設定可能ヒット件数（追加）
    Dim hitCount2 As Long, hitCount3 As Long

    '-------------------------------
    ' ひな形と保存フォルダ
    '-------------------------------
    templatePath = "C:\Templates\ひな形.xlsx"
    outputFolder = "C:\Output\"

    '-------------------------------
    ' コピー元ファイル選択
    '-------------------------------
    Set fileDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fileDialog
        .Title = "コピー元のExcelファイルを選択してください"
        .Filters.Clear
        .Filters.Add "Excelファイル", "*.xls; *.xlsx; *.xlsm"
        If .Show <> -1 Then
            MsgBox "キャンセルされました。", vbExclamation
            Exit Sub
        End If
        selectedFile = .SelectedItems(1)
    End With

    Set srcWB = Workbooks.Open(selectedFile)

    On Error GoTo SheetError
    Set srcSheet2 = srcWB.Sheets("Sheet2")
    Set srcSheet3 = srcWB.Sheets("Sheet3")
    On Error GoTo 0

    '-------------------------------
    ' 新規ファイル作成
    '-------------------------------
    newFileName = GetNextFileName(outputFolder, "サンプル_2025-", "xlsx")
    Set destWB = Workbooks.Open(templatePath)
    Set destSheet2 = destWB.Sheets("内容")
    Set destSheet3 = destWB.Sheets("詳細")

    '-------------------------------
    ' Sheet2 → 内容
    '-------------------------------
    lastRow = srcSheet2.Cells(srcSheet2.Rows.Count, "Z").End(xlUp).Row
    destRow = 2
    hitCount2 = 0                                  ' ← カウント初期化

    For i = 2 To lastRow
        If srcSheet2.Cells(i, "Z").Value = "設定可能" Then
            hitCount2 = hitCount2 + 1              ' ← 件数カウント
            srcSheet2.Range(srcSheet2.Cells(i, 2), srcSheet2.Cells(i, 26)).Copy
            destSheet2.Cells(destRow, 2).PasteSpecial Paste:=xlPasteValues
            destRow = destRow + 1
        End If
    Next i

    '-------------------------------
    ' Sheet3 → 詳細
    '-------------------------------
    lastRow = srcSheet3.Cells(srcSheet3.Rows.Count, "AL").End(xlUp).Row
    destRow = 2
    hitCount3 = 0                                  ' ← カウント初期化

    For i = 2 To lastRow
        If srcSheet3.Cells(i, "AL").Value = "設定可能" Then
            hitCount3 = hitCount3 + 1              ' ← 件数カウント
            srcSheet3.Range(srcSheet3.Cells(i, 3), srcSheet3.Cells(i, 38)).Copy
            destSheet3.Cells(destRow, 3).PasteSpecial Paste:=xlPasteValues
            destRow = destRow + 1
        End If
    Next i

    '-------------------------------
    ' ★ 追加部分：ヒット０件の場合の処理
    '-------------------------------
    If hitCount2 = 0 And hitCount3 = 0 Then
        destWB.Close SaveChanges:=False
        MsgBox "設定可能のデータが 1件もありませんでした。" & vbCrLf & _
               "新規ファイルは作成されません。", vbExclamation
        Exit Sub
    End If

    '-------------------------------
    ' 表紙：ファイル名書き込み
    '-------------------------------
    destWB.Sheets("表紙").Range("L2").Value = newFileName

    '-------------------------------
    ' 保存
    '-------------------------------
    destWB.SaveAs Filename:=outputFolder & newFileName, FileFormat:=xlOpenXMLWorkbook
    destWB.Close SaveChanges:=False

    Application.CutCopyMode = False

    MsgBox "ファイルを作成しました：" & vbCrLf & outputFolder & newFileName, vbInformation
    Exit Sub

SheetError:
    MsgBox "選択したブックに Sheet2 または Sheet3 が存在しません。", vbCritical
    Exit Sub

End Sub

Access の Connect に「ID/PW を保存させない」＋「Excel VBA で毎回セット」

Sub OpenAccessWithCredentials()

    Dim acc As Object
    Dim tdf As Object
    Dim db As Object

    Set acc = CreateObject("Access.Application")
    acc.OpenCurrentDatabase "C:\path\your.accdb"

    Set db = acc.CurrentDb

    For Each tdf In db.TableDefs
        If tdf.Connect <> "" Then
            tdf.Connect = "ODBC;DRIVER={Oracle in OraClient};DBQ=ORCL;" & _
                          "UID=your_id;PWD=your_password;"
            tdf.RefreshLink
        End If
    Next

    '--- クエリ実行例 ---
    acc.DoCmd.OpenQuery "Query1"

    acc.CloseCurrentDatabase
    acc.Quit

End Sub