カテゴリー
Excel VBA

gooブログバックアップデータの活用

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には対応してないのかも?

inserted by FC2 system