昨日の続きです。
はてなブログの管理ページから生成した、Movable Type形式の記事のエクスポートデータをExcelシートに出力するマクロです。
本マクロ実行前に、エクスポートデータを用意してください。
実行すると、現在アクティブになっているExcelブックの右端にシートを二つ追加して、一つ目に、全エクスポートデータを、二つ目のシートに、1記事1行で、記事情報を出力します。
出力内容は、以下の５項目。
・TITLE: 記事題名
・BASENAME: 記事URLの後半固有部分
・STATUS: 下書き／公開 区別
・DATE: 投稿日時
・CATEGORY: カテゴリ (複数ある場合は // にて結合しています)
以前投稿しましたコードに、今回追加したのは、最後の９行と、それに付随する各種プロシージャです。
'記事一覧を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)
Excel開発環境のVBE で、新規に標準モジュールを作成し、以下のコードを丸ごとコピーして貼り付けてもらえると、動くはずです。
念のためのお断りですが、本マクロの実行によるデータ破壊などには責任が持てません。実行は自己責任でお願いいたします。
本マクロの実行前に、作業中のExcelファイルなどは、保存して頂き、エラー発生時に大切なデータが消えてしまわないように対策をお願いいたします。
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) '配列データを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) 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 '◆=================================================== 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 txtArr2(mt, arr2Cnt) = "--------" arr2Cnt = arr2Cnt + 1 '記事通し番号 ReDim Preserve txtArr2(MAXmt, arr2Cnt) 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 '◆===================================================
コードは以上です。
記事一覧の出力結果は、セルの幅などの調整はしていませんので、見やすいように調整をお願いします。
今後は、記事にリンクを設定し、該当の記事にジャンプできるように機能を追加していきます。
また、HTML化し、実際にブログ内での記事一覧として使用できるようにする予定です。ちょっとずつやっていきます。
