VBA講座

Sub ExportByCAndX_Final_Variant()

    Dim wsBase As Worksheet
    Dim wbRef As Workbook, wsRef As Worksheet
    Dim wbOut As Workbook, wsOut As Worksheet
    Dim lastRow As Long, i As Long, j As Long
    Dim baseData As Variant
    Dim cVal As String, x As String, y As String
    Dim comboKey As String
    Dim zVal As Variant, aaVal As Variant, abVal As Variant, acVal As Variant, adVal As Variant
    Dim dictDone As Object
    Dim foundCell As Range, lastMatchCell As Range
    Dim firstAddress As String
    Dim refPath As String
    Dim savePath As String
    Dim outRow As Long
    Dim fDialog As FileDialog
    Dim totalRows As Long
    Dim colIndexes As Variant

    Set wsBase = ThisWorkbook.Sheets(1)
    lastRow = wsBase.Cells(wsBase.Rows.Count, "C").End(xlUp).Row
    baseData = wsBase.Range("A2:AD" & lastRow).Value
    totalRows = UBound(baseData, 1)

    Set dictDone = CreateObject("Scripting.Dictionary")

    ' ▼ 出力先フォルダ選択
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With fDialog
        .Title = "出力先フォルダを選択してください"
        If .Show <> -1 Then
            MsgBox "キャンセルされました。処理を終了します。"
            Exit Sub
        End If
        savePath = .SelectedItems(1) & "\"
    End With

    ' ▼ 確認
    If MsgBox("以下のフォルダに出力します。よろしいですか？" & vbCrLf & vbCrLf & savePath, vbYesNo + vbQuestion, "出力先の確認") = vbNo Then
        MsgBox "処理をキャンセルしました。"
        Exit Sub
    End If

    ' ▼ 参照ブックを開く（パスは適宜修正）
    refPath = "C:\path\to\参照先ブック.xlsx"
    Set wbRef = Workbooks.Open(refPath)
    Set wsRef = wbRef.Sheets("データ")

    ' ▼ 出力用ブック・シート作成
    Set wbOut = Workbooks.Add
    Set wsOut = wbOut.Sheets(1)
    wsOut.Name = "出力結果"
    outRow = 1

    ' ▼ 出力する列の番号（例：1列目、3列目、26〜30列目）→ 必要に応じて調整
    colIndexes = Array(1, 3, 26, 27, 28, 29, 30)

    ' ▼ メインループ
    For i = 1 To totalRows
        Application.StatusBar = "処理中... (" & i & "/" & totalRows & ")"

        x = Trim(baseData(i, 1))        ' A列
        y = Trim(baseData(i, 4))        ' D列 ← 追加
        cVal = Trim(baseData(i, 3))     ' C列
        zVal = baseData(i, 26)          ' Z列
        aaVal = baseData(i, 27): abVal = baseData(i, 28)
        acVal = baseData(i, 29): adVal = baseData(i, 30)

        comboKey = cVal & "___" & x & "___" & y

        If zVal <> "廃止" And (aaVal = "◯" Or abVal = "◯" Or acVal = "◯" Or adVal = "◯") Then
            If Len(x) > 0 And Len(cVal) > 0 Then
                If Not dictDone.exists(comboKey) Then
                    Set foundCell = wsRef.Columns("A").Find(What:=x, LookIn:=xlValues, LookAt:=xlWhole)
                    If Not foundCell Is Nothing Then
                        Set lastMatchCell = foundCell
                        firstAddress = foundCell.Address

                        Do
                            If foundCell.Row > lastMatchCell.Row Then
                                Set lastMatchCell = foundCell
                            End If
                            Set foundCell = wsRef.Columns("A").FindNext(foundCell)
                        Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress

                        ' ▼ 必要な列だけ出力
                        For j = 0 To UBound(colIndexes)
                            wsOut.Cells(outRow, j + 1).Value = wsRef.Cells(lastMatchCell.Row, colIndexes(j)).Value
                        Next j
                        outRow = outRow + 1

                        dictDone.Add comboKey, True
                    End If
                End If
            End If
        End If
    Next i

    ' ▼ 保存処理
    wbOut.SaveAs Filename:=savePath & "出力結果.xlsx"
    wbOut.Close SaveChanges:=False
    wbRef.Close SaveChanges:=False
    Application.StatusBar = False
    MsgBox "完了しました！"

End Sub