script_dev/機能仕様書作成/Module3.bas

Attribute VB_Name = "Module3"
Sub ExportMarkdown_Complete()

    Application.ScreenUpdating = False

    '==============================
    ' 0. 基本情報（変換定義側）
    '==============================
    Dim defWs As Worksheet
    Set defWs = ThisWorkbook.Sheets("要求仕様書変換")

    Dim sourcePath As String
    sourcePath = defWs.Range("C3").Value          ' 取得元Excel

    Dim sheetNames() As String
    sheetNames = Split(defWs.Range("C4").Value, vbLf) ' 対象シート（改行区切り）

    Dim startRow As Long
    startRow = defWs.Range("C5").Value             ' 探索開始行

    Dim OutPutStyle As String
    OutPutStyle = defWs.Range("C6").Value         ' 出力スタイル

    Dim title As String
    title = defWs.Range("N3").Value                ' Markdownタイトル

    Dim template As String
    template = defWs.Range("M5").Value             ' Markdownテンプレート

    Dim titleTemplate As String
    titleTemplate = defWs.Range("M4").Value             ' Markdownテンプレート

    '==============================
    ' 1. 項目定義（B/C/F列）
    '==============================
    ' key   : B列（{B6} 等で使うキー）
    ' value : Array(取得元列記号, 条件)
    Dim items As Object
    Set items = CreateObject("Scripting.Dictionary")

    Dim defRow As Long
    defRow = 7

    Do While defWs.Cells(defRow, 2).Value <> ""
        items.Add defWs.Cells(defRow, 2).Value, _
                  Array(defWs.Cells(defRow, 3).Value, _
                        defWs.Cells(defRow, 6).Value)
        defRow = defRow + 1
    Loop

    '==============================
    ' 2. 取得元 Excel を開く
    '==============================
    Dim srcWb As Workbook
    Set srcWb = Workbooks.Open(sourcePath, ReadOnly:=True)

    ' 種別まとめ用
    Dim categoryMap As Object
    Set categoryMap = CreateObject("Scripting.Dictionary")

    ' 種別なしブロック
    Dim normalBlocks As String
    normalBlocks = ""

    '==============================
    ' 3. シート単位で処理
    '==============================
    Dim sn As Variant
    For Each sn In sheetNames

        Dim dataWs As Worksheet
        Set dataWs = srcWb.Sheets(Trim(sn))

        Dim r As Long
        r = startRow

        ' 最初の定義列が空になるまで
        Do While dataWs.Cells(r, Columns(items.items()(0)(0)).Column).Value <> ""

            Dim md As String
            md = template          ' ★ テンプレートを複製

            Dim titlemd As String
            titlemd = titleTemplate          ' ★ テンプレートを複製

            Dim category As String
            category = ""

            Dim categoryFixed As String
            categoryFixed = ""

            Dim key As Variant
            For Each key In items.Keys

                Dim colLetter As String
                Dim cond As String
                colLetter = items(key)(0)
                cond = items(key)(1)

                If cond = "種別(固定)" Then
                    categoryFixed = dataWs.Range(colLetter).Value
                Else
                    Dim colNum As Long
                    colNum = Columns(colLetter).Column

                    Dim cellValue As String
                    cellValue = dataWs.Cells(r, colNum).Value
                    cellValue = Replace(cellValue, vbCrLf, vbLf)
                    cellValue = Replace(cellValue, Chr(13), vbLf)
                End If

                Select Case cond

                    Case "箇条書き"
                        Dim lines() As String
                        lines = Split(cellValue, vbLf)

                        Dim listText As String
                        Dim i As Long
                        For i = LBound(lines) To UBound(lines)
                            If Trim(lines(i)) <> "" Then
                                listText = listText & "- " & lines(i) & vbCrLf
                            End If
                        Next i
                        cellValue = Trim(listText)

                    Case "種別(表)"
                        category = cellValue
                        cellValue = ""   ' テンプレートには出さない
                    
                    Case "種別(固定)"
                        If category = "" Then
                            category = Replace(titlemd, "{" & key & "}", categoryFixed)
                        Else
                            category = Replace(category, "{" & key & "}", categoryFixed)
                        End If
                        cellValue = ""   ' テンプレートには出さない

                    Case Else
                        ' なし：そのまま使用
                End Select

                ' ★ テンプレート置換
                md = Replace(md, "{" & key & "}", cellValue)

            Next key

            '==============================
            ' 4. 種別ごとに格納
            '==============================
            If category <> "" Then
                If categoryMap.Exists(category) Then
                    categoryMap(category) = categoryMap(category) & vbCrLf & md
                Else
                    If OutPutStyle = "表" Then
                        categoryHeader = Replace(template, "{", "")
                        categoryHeader = Replace(categoryHeader, "}", "")
                        categoryLine = ReplaceExceptTarget(template, "|", "-")
                        categoryMap.Add category, categoryHeader & vbCrLf & categoryLine & vbCrLf & md
                    Else
                        categoryMap.Add category, md
                    End If
                End If
            Else
                normalBlocks = normalBlocks & vbCrLf & md
            End If

            r = r + 1
        Loop
    Next sn

    ' 既に開いていた場合はクローズしない
    If Not srcWb Is Nothing Then
        If srcWb.ReadOnly Then
            srcWb.Close False
        End If
    End If

    '==============================
    ' 5. Markdown 全体を生成
    '==============================
    Dim output As String
    output = ""

    ' タイトル
    If title <> "" Then
        output = "# " & title & vbCrLf & vbCrLf
    End If

    ' 種別ブロック
    Dim cat As Variant
    For Each cat In categoryMap.Keys
        output = output & "## " & cat & vbCrLf & vbCrLf
        output = output & categoryMap(cat) & vbCrLf & vbCrLf
    Next cat

    ' 種別なし
    output = output & normalBlocks

    '==============================
    ' 6. Markdown ファイル生成
    '==============================
    Dim outPath As String
    outPath = ThisWorkbook.path & "\output.md"

    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    stream.Charset = "UTF-8"
    stream.Open
    stream.WriteText output
    stream.SaveToFile outPath, 2   ' 2 = 上書き
    stream.Close

    MsgBox "Markdownファイルを生成しました：" & vbCrLf & outPath, vbInformation

    Application.ScreenUpdating = True

End Sub

Function ReplaceExceptTarget( _
    ByVal src As String, _
    ByVal targetChar As String, _
    ByVal replaceStr As String) As String

    Dim i As Long
    Dim result As String
    Dim ch As String

    For i = 1 To Len(src)
        ch = Mid(src, i, 1)

        If ch = targetChar Then
            result = result & ch
        Else
            result = result & replaceStr
        End If
    Next i

    ReplaceExceptTarget = result
End Function