csv

Option Explicit

'========================================================
' エントリーポイント：テストシート1 → テストシート2 を順にCSV出力
'========================================================
Public Sub Export_TestSheets_ToCsv_SJIS()
Dim saveFolder As String
saveFolder = GetDefaultDesktopPath() ' デスクトップに出す（必要ならここを変える）

ExportOneSheetCsvSJIS "テストシート1", saveFolder
ExportOneSheetCsvSJIS "テストシート2", saveFolder

MsgBox "CSV出力が完了しました。" & vbCrLf & "出力先: " & saveFolder, vbInformation

End Sub

'========================================================
' 1シート分の処理
'========================================================
Private Sub ExportOneSheetCsvSJIS(ByVal sheetName As String, ByVal saveFolder As String)
Dim ws As Worksheet
Set ws = GetWorksheetByName(sheetName)
If ws Is Nothing Then
MsgBox "シートが見つかりません: " & sheetName, vbExclamation
Exit Sub
End If

' ②「出力対象」と書かれたセルを探す（見出しセル）
Dim headerCell As Range
Set headerCell = FindCellByExactText(ws, "出力対象")
If headerCell Is Nothing Then
    MsgBox "「出力対象」セルが見つかりません: " & sheetName, vbExclamation
    Exit Sub
End If

Dim flagCol As Long
flagCol = headerCell.Column

' ③ 出力対象列に「⚫︎」がある行を抽出し、
'   「そのセルの右側」から右に23個分（合計24列）を出力対象とする
Dim lastRow As Long
lastRow = GetLastUsedRow(ws, flagCol)

Dim outLines() As String
Dim outCount As Long
outCount = 0

Dim r As Long
For r = headerCell.Row + 1 To lastRow
    Dim v As String
    v = Trim$(CStr(ws.Cells(r, flagCol).Value))

    If v = "⚫︎" Or v = "●" Then ' 入力が●になってるケースも吸収
        Dim startCol As Long
        startCol = flagCol + 1 ' 右側のセルから開始

        Dim line As String
        line = BuildCsvLine(ws, r, startCol, 24) ' 右に23個分 = 合計24列
        outCount = outCount + 1
        ReDim Preserve outLines(1 To outCount)
        outLines(outCount) = line
    End If
Next r

' ④ CSV出力（Shift_JIS）
Dim filePath As String
filePath = saveFolder & "\" & sheetName & "_" & Format(Now, "yyyymmdd_hhnnss") & ".csv"

' ★最後は必ず改行を付ける（CRLF）
Dim body As String
body = JoinSafe(outLines, vbCrLf) & vbCrLf

WriteTextFileSJIS filePath, body

End Sub

'========================================================
' CSV 1行生成：指定行の指定列範囲をCSVとして組み立て
'========================================================
Private Function BuildCsvLine(ByVal ws As Worksheet, ByVal rowIndex As Long, ByVal startCol As Long, ByVal colCount As Long) As String
Dim i As Long
Dim parts() As String
ReDim parts(1 To colCount)

For i = 0 To colCount - 1
    Dim cellVal As String
    cellVal = CStr(ws.Cells(rowIndex, startCol + i).Value)

    ' CSV用にエスケープ（ダブルクォート、カンマ、改行対策）
    parts(i + 1) = CsvEscape(cellVal)
Next i

BuildCsvLine = Join(parts, ",")

End Function

'========================================================
' CSVエスケープ
' - , " 改行 を含む場合は "..." で囲む
' - " は "" に変換
'========================================================
Private Function CsvEscape(ByVal s As String) As String
Dim needsQuote As Boolean
needsQuote = (InStr(s, ",") > 0) Or (InStr(s, """") > 0) Or (InStr(s, vbCr) > 0) Or (InStr(s, vbLf) > 0)

' " は "" にする
s = Replace(s, """", """" & """")

If needsQuote Then
    CsvEscape = """" & s & """"
Else
    CsvEscape = s
End If

End Function

'========================================================
' Shift_JISでテキストファイル書き込み（ADODB.Stream）
'========================================================
Private Sub WriteTextFileSJIS(ByVal filePath As String, ByVal text As String)
Dim stm As Object
Set stm = CreateObject("ADODB.Stream")

With stm
    .Type = 2 ' adTypeText
    .Charset = "Shift_JIS"
    .Open
    .WriteText text

    ' 上書き保存
    .SaveToFile filePath, 2 ' adSaveCreateOverWrite
    .Close
End With

End Sub

'========================================================
' 「出力対象」セルを完全一致で探す
'========================================================
Private Function FindCellByExactText(ByVal ws As Worksheet, ByVal targetText As String) As Range
Dim f As Range
Set f = ws.Cells.Find(What:=targetText, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then
Set FindCellByExactText = f
Else
Set FindCellByExactText = Nothing
End If
End Function

'========================================================
' 最終行（指定列を基準）
'========================================================
Private Function GetLastUsedRow(ByVal ws As Worksheet, ByVal baseCol As Long) As Long
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, baseCol).End(xlUp).Row
If lastRow < 1 Then lastRow = 1
GetLastUsedRow = lastRow
End Function

'========================================================
' シート取得（存在しない場合はNothing）
'========================================================
Private Function GetWorksheetByName(ByVal sheetName As String) As Worksheet
On Error Resume Next
Set GetWorksheetByName = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
End Function

'========================================================
' Joinの安全版（0件なら空文字）
'========================================================
Private Function JoinSafe(ByRef lines() As String, ByVal delimiter As String) As String
On Error GoTo NO_DATA
JoinSafe = Join(lines, delimiter)
Exit Function
NO_DATA:
JoinSafe = ""
End Function

'========================================================
' デスクトップパス取得
'========================================================
Private Function GetDefaultDesktopPath() As String
GetDefaultDesktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
End Function