Sub BlogBKDateToExcel()
Dim work As String, work2 As String
Dim inWord(10) As String
Dim i As Integer, j As Integer, k As Integer
Dim w1 As Integer, w2 As Integer
Dim ans As String
Dim ws0 As String
Dim pattern(10) As String
pattern(1) = "AUTHOR:"
pattern(2) = "TITLE:"
pattern(3) = "DATE:"
pattern(4) = "PRIMARY CATEGORY:"
pattern(5) = "STATUS:"
pattern(6) = "ALLOW COMMENTS:"
pattern(7) = "CONVERT BREAKS:"
pattern(8) = "-----"
pattern(9) = "BODY:"
pattern(10) = "--------"
Call HeaderPrint(pattern)
i = 1
Worksheets("sheet1").Activate 'ワークシートは1とします
Open "d:\blog\blogbk15-21.txt" For Input As #1 'バックアップファイルを展開してもの
Do Until EOF(1)
For k = 1 To 9
ans = ""
Input #1, work
NyuryokuPass:
If StrComp(work, pattern(9)) = 0 Then 'BODYの場合
Do
Input #1, work2
ans = ans + work2 '終了でない時は、読み込んだデーに加える
Loop While StrComp(work2, pattern(10)) <> 0 '終了でないうちは続けるpattern(10)はブログの区切り
inWord(k) = ans
Else 'BODY以外の処理
If StrComp(work, pattern(8)) <> 0 Then '-----は無視する。前回データを格納に行きます
w1 = InStr(work, ":")
ws0 = Mid(work, 1, w1)
ans = Right(work, Len(work) - Len(pattern(k)) - 1) 'TITLEの一番最初に読み込んだ処理
Do 'TITLEの読込が最後まで行くの行かないのか?
Input #1, work2
If StrComp(work2, pattern(8)) = 0 Then
inWord(k) = ans
k = k + 1
work = work2
GoTo NyuryokuPass
Else
w2 = InStr(work2, ":") '入力が途中で終わっているか?
If w2 = 0 Then '入力が途中、TITLEに半角","が入っている時
ans = ans + work2 + "、" '半角,を全角、で置換え
Else
inWord(k) = ans
k = k + 1
work = work2
GoTo NyuryokuPass
End If
End If
Loop While w2 = 0 '"DATE:"が出てくるまで、続ける
inWord(k) = ans '読み込んだデータがpattern(8)の時、前回データを格納します
End If
End If
Next k
i = i + 1
w0 = 0
For j = 1 To 9
If j = 9 Then
w0 = -1
End If
If j >= 4 Then
Cells(i, j + 2 + w0).Value = inWord(j)
Else
Cells(i, j).Value = inWord(j)
End If
Next j
Input #1, work
Loop
Close #1
Call ハイパーリンク作成
Call 表全体を検索
MsgBox "処理を終わります"
End Sub
Sub HeaderPrint(patterns() As String)
Cells(1, 1) = patterns(1)
Cells(1, 2) = patterns(2)
Cells(1, 3) = patterns(3)
Cells(1, 4) = "WorkDate"
Cells(1, 5) = "HyperLink"
Cells(1, 6) = patterns(4)
Cells(1, 7) = patterns(5)
Cells(1, 8) = "Comments"
Cells(1, 9) = "Breaks"
Cells(1, 10) = patterns(9)
End Sub
Sub ハイパーリンク作成()
Dim i As Integer
Dim last As Integer
last = Cells(2, 1).End(xlDown).Row
For i = 2 To last
Range("d" & i).FormulaR1C1 = "=TEXT(RC[-1], ""yyyymmdd"")"
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 5), _
Address:="https://blog.goo.ne.jp/" + Cells(i, 1) + "/d/" + Cells(i, 4), _
TextToDisplay:="https://blog.goo.ne.jp/isamrx72/d/" + Cells(i, 4)
Next
'MsgBox "ハイパーリンクの作成終了"
End Sub
Sub テキストボックスを作る()
'
' テキストボックスを作る Macro
'
' Keyboard Shortcut: Ctrl+t
'
Worksheets("sheet1").Activate
Dim i As Long
Dim j As Long
Dim 範囲 As Range
Dim ws As Worksheet
Set ws = ActiveSheet
i = ActiveCell.Row
j = ActiveCell.Column
Set 範囲 = Range(Cells(i + 1, j), Cells(i + 6, j + 5))
Dim shp As Shape
Set shp = ws.Shapes.AddTextbox _
(Orientation:=msoTextOrientationHorizontal, _
Left:=範囲.Left, Top:=範囲.Top, _
Width:=範囲.Width, Height:=範囲.Height)
shp.TextFrame.Characters.Font.Size = 10
Dim chars As Characters
Set chars = shp.TextFrame.Characters
chars.Text = Cells(i, j).Value
chars.Font.Color = RGB(255, 0, 0)
End Sub
Sub テキストボックスの全削除()
'
' テキストボックスの全削除 Macro
'
' Keyboard Shortcut: Ctrl+k
'
Worksheets("sheet1").Activate
Dim sp As Shape
For Each sp In ActiveSheet.Shapes
sp.Delete
Next
End Sub
Sub 表全体を検索()
'
' 表全体を検索 Macro
'
' Keyboard Shortcut: Ctrl+z
'
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.AutoFilter
Range("A1").Select
End Sub
多分、コード自体は良いと思いますが、テキストの色付けがおかしいようです。VBAには対応してないのかも?