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

昨日まで作成してきました記事一覧の各記事の題名にハイパーリンクを設定する処理を追加しました。

Excel シートに記事一覧を追加した後に、シートを上から１記事ずつハイパーリンクを追加しています。（ActiveSheet.Hyperlinks.Add を利用しています）

一点注意して頂きたいのが設定するＵＲＬの書き換えです。

動かす前に、プロシージャ「Sub ハイパーリンク設定(textCell, urlCell, rw) 」の
fixURL = "https://www.自分のブログのURL/entry/"

この部分を、自分のブログの固定URLに変更してください

Sub ハイパーリンク設定(textCell, urlCell, rw)

'固定URL
    Dim fixURL As String
'★→自分のブログのURLに変更してください
    fixURL = "https://www.自分のブログのURL/entry/"

また、出力後のExcelシート上のハイパーリンクで、下書き状態の記事(STATUS: =Draft) のURLを開こうとすると

Entry is not found

お探しの記事は見つかりませんでした。

と表示されます。

今回追加したコードは、以下の部分と、それに付随するプロシージャです。
処理が完了すると、メッセージボックスに「出力完了！記事数：○○」が表示されるようにしましたので、この表示が出るまでしばらくお待ちください。

'ハイパーリンク設定
    Dim rw As Long  '記事数
    rw = 0
    Call ハイパーリンク設定(stCell2.Offset(1, 0), stCell2.Offset(1, 1), rw)

    MsgBox "出力完了！ " & "記事数 : " & rw

以下、今回変更を盛り込んだコードです。

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

'ハイパーリンク設定
    Dim rw As Long  '記事数
    rw = 0
    Call ハイパーリンク設定(stCell2.Offset(1, 0), stCell2.Offset(1, 1), rw)

    MsgBox "出力完了！ " & "記事数 : " & rw

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


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


Sub ハイパーリンク設定(textCell, urlCell, rw)

'textCell: ハイパーリンクを設定する文字列の開始セル
'urlCell: URLを格納している開始セル
'rw : 記事数

'固定URL
    Dim fixURL As String
'★→自分のブログのURLに変更してください
    fixURL = "https://www.自分のブログのURL/entry/"
    
    Do
        If urlCell.Offset(rw, 0).Value = "" Then Exit Do
        If textCell.Offset(rw, 0).Value <> "" Then
            ActiveSheet.Hyperlinks.Add _
                Anchor:=textCell.Offset(rw, 0), _
                Address:=fixURL & urlCell.Offset(rw, 0), _
                TextToDisplay:=textCell.Offset(rw, 0).Value
        End If
        DoEvents
        rw = rw + 1
    Loop
    
    Debug.Print "記事数 "; rw
    
'ActiveSheet.Hyperlinks.Add _
'       Anchor:=セル位置, _
'       Address:="URL", _
'       TextToDisplay:="URLを設定する文字列"


End Sub


'◆===================================================こ

コードは以上です。

今後は、各記事の文字数表示などを付け加えていきたいと思います。

自分方位研究所

日々の活動記録

はてなブログの記事一覧。タイトルにハイパーリンク設定

Entry is not found