自分方位研究所

日々の活動記録

(昨日の修正)Movable Type形式のエクスポートデータから記事一覧をExcelシートに出力するマクロ

昨日のコードの訂正です。

行の始まりが「--------」(- が8個連続) であると、それを記事の終了部分と認識し、1記事分の空白行を作るようになっていました。

f:id:k-emu:20220321222953j:plain

上記のような状態だと、以下のように空白行ができてしまいます。

f:id:k-emu:20220321223009j:plain

 

そこで新たに、記事の終了確認処理を新たに追加しました。
「--------」(- が8個連続) だけで、記事の終りと判断せず、
・1行分の文字が(- が8個連続) のみか
・BASENAME (URL) に既に値が入っているか

の2点を確認して1記事分の完了と判断するようにしています。

'◆===================================================

Sub 記事区切りの正当性確認(tgtStr, mtData, txtBASENAME, ok)

'tgtStr :1行分の文字列
'mtData :"--------"
'txtBASENAME : BASENAME (配列の2個目)
'ok :正常=1
    
'確認する行が "--------"のみで、かつ BASENAME に値が入っているとき ok=1
    
    ok = 0
    Dim tmpText As String
    tmpText = WorksheetFunction.Clean(tgtStr)
    If Len(tmpText) = Len(mtData) Then
        If txtBASENAME <> "" Then
            ok = 1
        End If
    End If

End Sub

'◆===================================================

 

あと、記事一覧をExcelシートに貼り付けてから、Title以外の列をAutoFitにてセルの幅を広げるようにしました。

    Range(stCell2.Offset(0, 1), stCell2.Offset(0, 3)).EntireColumn.AutoFit

 

以下が、昨日分の修正コードです。

 

Sub MovableType形式エクスポートファイルから記事一覧作成()
    
'事前に、はてなブログの管理ページからMovableType形式の
'エクスポートファイルをダウンロードしておいてください。
    
    Dim filePas As String
    filePas = ファイルパスを取得
    If filePas = "False" Then End

'エクスポートデータ出力用シートを追加する
    Dim stCell As Range
    Set stCell = 出力開始セルを指定
    
    Dim tmpText As String
    tmpText = UTF8をSHIFTJIS化(filePas)

'テキストファイルを配列化(改行コード"vbLf"で区切る)
    Dim txtArr As Variant
    txtArr = Split(tmpText, vbLf)
    
''セル内改行を削除する
'    Call セル内改行を削除(txtArr)

'配列データをExcelシートへ出力(縦方向に出力)
    Range(stCell, stCell.Offset(UBound(txtArr), 0)) = _
    WorksheetFunction.Transpose(txtArr)

'記事一覧を2次元配列化
    Dim txtArr2() As Variant '新規格納先配列
    Call 記事情報抜き出し配列化(txtArr, txtArr2)

'記事一覧出力シートを追加する
    Dim stCell2 As Range
    Set stCell2 = 出力開始セルを指定

'配列データをExcelシートへ出力
    Range(stCell2, stCell2.Offset(UBound(txtArr2, 2), 5)) = _
    WorksheetFunction.Transpose(txtArr2)
    Range(stCell2.Offset(0, 1), stCell2.Offset(0, 3)).EntireColumn.AutoFit

End Sub


'◆===================================================

Function ファイルパスを取得() As String

'ダイアログボックスを開いてファイルを選択する。
    
    ファイルパスを取得 = Application.GetOpenFilename( _
        FileFilter:="Text(*.txt),*.txt,CSV,*.csv,全部(*.*),*.*", _
        TITLE:="MovableType形式の記事エクスポートファイルを選択")
        
    Debug.Print ファイルパスを取得
    
    'ファイル選択でフルパスファイル名。キャンセルすると「False」を返す。

End Function


'◆===================================================


Function 出力開始セルを指定() As Range

'アクティブなブックにワークシートを1つ右端に追加。

    Worksheets.Add after:=Sheets(Sheets.Count)
    Set 出力開始セルを指定 = ActiveSheet.Range("A1")

End Function


'◆===================================================

Function UTF8をSHIFTJIS化(filePas) As String

    Dim ADODBobj As Object
    Set ADODBobj = CreateObject("ADODB.Stream")
    
    With ADODBobj
        .Charset = "UTF-8" '"UTF-8" "SHIFT-JIS" '"UTF-8"
        .Open
        .LoadFromFile filePas
    End With
    
    UTF8をSHIFTJIS化 = ADODBobj.ReadText
    
    ADODBobj.Close

    Set ADODBobj = Nothing

End Function


'◆===================================================


Sub セル内改行を削除(txtArr)

    Dim i As Long
    For i = 0 To UBound(txtArr)
        'txtArr(i) = Replace(txtArr(i), vbLf, "")
        'txtArr(i) = Replace(txtArr(i), vbCr, "")
        'txtArr(i) = Replace(txtArr(i), vbCrLf, "")
        txtArr(i) = WorksheetFunction.Clean(txtArr(i))
    Next i

End Sub


'◆===================================================


Function 記事情報抜き出し配列化(txtArr, txtArr2)

    Dim mt As Byte  'エクスポートデータの項目番号
    Dim tgtStr As String    'エクスポートデータの1行分の文字列
    Dim mtData As Variant   'エクスポートデータの見出語(メタデータ・セクション)
    Dim fixTxt As String    '整形後の1行分の文字列

    Dim MAXmt As Byte 'エクスポートデータの項目数
    MAXmt = 5
    Call txtArr2の先頭に見出しを設定(txtArr2, MAXmt)

    Dim arr2Cnt As Long '記事数(通し番号)
    arr2Cnt = 1
    ReDim Preserve txtArr2(MAXmt, arr2Cnt)
    
    Dim ok As Byte  '先頭文字が見つかったら=1
    Dim rw As Long
    For rw = 0 To UBound(txtArr)  '配列要素カウンタ(行数)
        tgtStr = txtArr(rw) '1行分の文字列データ
        
        Call 有効文字抽出(tgtStr, mt, MAXmt, mtData, fixTxt, ok)
        If ok = 1 Then
            If mtData = "CATEGORY: " Then
                Call CATEGORY複数処理(txtArr2, mt, arr2Cnt, fixTxt)
            End If
            txtArr2(mt, arr2Cnt) = fixTxt
        
            If mtData = "--------" Then
                Call 記事区切りの正当性確認(tgtStr, mtData, txtArr2(1, arr2Cnt), ok)
                If ok = 1 Then
    '                txtArr2(mt, arr2Cnt) = "--------"
                    arr2Cnt = arr2Cnt + 1   '記事通し番号
                    ReDim Preserve txtArr2(MAXmt, arr2Cnt)
                End If
            End If
        End If
    Next rw
    
End Function


'◆===================================================


Sub txtArr2の先頭に見出しを設定(txtArr2, MAXmt)

    ReDim Preserve txtArr2(MAXmt, 0)
    Dim mt As Byte
    Dim mtData As Variant
    
    For mt = 0 To MAXmt
        Call セレクトケース記事見出し(mt, mtData)
        txtArr2(mt, 0) = mtData
    Next mt
    
End Sub


'◆===================================================


Sub セレクトケース記事見出し(mt, mtData)

    Select Case mt
        Case 0
            mtData = "TITLE: "
        Case 1
            mtData = "BASENAME: "
        Case 2
            mtData = "STATUS: "
        Case 3
            mtData = "DATE: "
        Case 4
            mtData = "CATEGORY: "
        Case 5
            mtData = "--------"
    End Select

End Sub


'◆===================================================


Sub 有効文字抽出(tgtStr, mt, MAXmt, mtData, fixTxt, ok)

    ok = 0
    For mt = 0 To MAXmt
        Call セレクトケース記事見出し(mt, mtData)
        If Left(tgtStr, Len(mtData)) = mtData Then
            fixTxt = Right(tgtStr, Len(tgtStr) - Len(mtData))
            ok = 1
            Exit For
        End If
    Next mt

End Sub


'◆===================================================


Sub CATEGORY複数処理(txtArr2, mt, arr2Cnt, fixTxt)

'CATEGORY:が複数存在する場合、//挟んで追加する

    If Len(txtArr2(mt, arr2Cnt)) <> 0 Then
        fixTxt = txtArr2(mt, arr2Cnt) & "//" & fixTxt
    End If

End Sub


'◆===================================================


Sub 記事区切りの正当性確認(tgtStr, mtData, txtBASENAME, ok)

'tgtStr :1行分の文字列
'mtData :"--------"
'txtBASENAME : BASENAME (配列の2個目)
'ok :正常=1
    
'確認する行が "--------"のみで、かつ BASENAME に値が入っているとき ok=1
    
    ok = 0
    Dim tmpText As String
    tmpText = WorksheetFunction.Clean(tgtStr)
    If Len(tmpText) = Len(mtData) Then
        If txtBASENAME <> "" Then
            ok = 1
        End If
    End If

End Sub


'◆===================================================

 

以上です。 
明日は先頭のTitle文字列に、ハイパーリンクを設定したいと思います。