昨日のコードの訂正です。
行の始まりが「--------」(- が8個連続) であると、それを記事の終了部分と認識し、1記事分の空白行を作るようになっていました。
上記のような状態だと、以下のように空白行ができてしまいます。
そこで新たに、記事の終了確認処理を新たに追加しました。
「--------」(- が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文字列に、ハイパーリンクを設定したいと思います。