245 lines
7.5 KiB
QBasic
245 lines
7.5 KiB
QBasic
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)
|
||
|
||
Dim cellValue As String
|
||
|
||
If cond = "種別(固定)" Then
|
||
categoryFixed = dataWs.Range(colLetter).Value
|
||
ElseIf cond = "種別(表)" Then
|
||
cellValue = dataWs.Range(colLetter).Value
|
||
Else
|
||
Dim colNum As Long
|
||
colNum = Columns(colLetter).Column
|
||
|
||
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
|
||
|