【Excel】属性指定検索／属性をタグに変換

ExcelのVBAって、面倒すぎる……BASICってこんなに使いにくかったっけか？

といっても、ほとんどN88-BASIC(86)しかいじったこと無いけど

ヘルプも極めて使いづらいし(_ _;)/。
これで上手にプログラム組める人、尊敬しますわ。

今度もお仕事がらみ。
先日の続きで、インデントが深くなりすぎて、各要素の関係がExcelの表だとさっぱりわからないため、XMLに変換してみようと思いつく。

ExcelにもXML出力はあるけれど、ユーザとしては必要の無い情報が多いし解析が面倒なので深く考えずにパス。
CSV出力をPerlで整形してXMLにすることに。

そちらはとりあえず雛形が出来たのだけれども、考えてみれば、文字の色や背景色の属性は CSV には落ちてくれない……Excel上では削除・追加箇所などを色分けしたりしているので、これだと少々不便。

で、ExcelのVBAで、色などの属性をタグに置換することを思いつき……実現しようとして、はまる。

あ、どうせならVBAでXMLに変換しろよ、とかいうの禁止(苦笑)

まず、属性指定の検索方法がわからなかったので、いろいろ調べてみたところ、こんな感じで出来る模様(取り消し線指定されているセルを検索するサンプル)。

Sub searchStrikethroughCell()
    With Application.FindFormat
        .Clear
        With .Font
            .Strikethrough = True
        End With
    End With
    

    Dim FoundCell As Range
    Set FoundCell = ActiveCell.CurrentRegion.Find(What:="*", After:=ActiveCell, SearchOrder:=xlByRows, _
      SearchDirection:=xlNext, SearchFormat:=True)
    
    If FoundCell Is Nothing Then
        MsgBox "見つかりませんでした"
    Else
        FoundCell.Activate
    End If
    
End Sub

ところが、セル中の文字列の一部だけに取り消し線が設定されているような場合だと、上の方法だと検索にかからない……。

結局、うまい方法が見つからないため、地道に有効なセルを順にたどり、さらにその中身を Characters を使って一文字ずつ属性を調べるという、全く持って効率の悪い方法に。

それに、属性自体はなるべく保存したままにしたかったので、最初は
.Characters(locate, length).text = tagStart + .Characters(locate, length).text + tagEnd
のような感じで、見つかった文字列を整形してその範囲だけタグを付けて置換、という方法でやっていたのだが、どうやら、整形後のセルのテキスト全体が256文字を越えてしまうと、.Characters(locate, length).text への代入が無視されてしまう(256文字以下だときちんと置き換わる)、という現象に気づき、泣く泣くテキスト全体を置換することに。
これだともともとの属性が死んでしまうのだが、やむをえない。

うまい方法があったら教えてください＞有識者

とりあえず、
取り消し線付き文字列→<del>～</del>
赤色文字列→<add>～</add>
とするサンプル。

Sub changeAttribute()
    For Each currentRange In ActiveSheet.UsedRange
        currentRange.Activate
        addTags
    Next
    MsgBox ("属性をタグに置換しました")
End Sub

Sub addTags()
    Dim ci, cj, length, mode As Long
    Dim chgText, tmpText As String
    
    length = 0
    mode = 0
    isIndent = 1
    
    With ActiveCell
        chgText = ""
        ci = 1
        If Application.WorksheetFunction.IsText(.Value) = True Then
        
            Do While ci <= .Characters.Count
                If isIndent = 1 Then
                    If .Characters(ci, 1).text <> ">" And .Characters(ci, 1).text <> " " Then
                        isIndent = 0
                    End If
                End If
                If isIndent = 0 Then
                    If .Characters(ci, 1).Font.Strikethrough = True Then
                        mode = 1
                        tagStart = "<del>"
                        tagEnd = "</del>"
                    ElseIf .Characters(ci, 1).Font.ColorIndex = 3 Then ' Red
                        mode = 2
                        tagStart = "<add>"
                        tagEnd = "</add>"
                    End If
                End If
                If mode <> 0 Then
                    tmpText = .Characters(ci, 1).text
                    length = length + 1
                    For cj = ci + 1 To .Characters.Count
                        If (mode = 1 And .Characters(cj, 1).Font.Strikethrough = True) Or _
                            (mode = 2 And .Characters(cj, 1).Font.ColorIndex = 3) Then
                            tmpText = tmpText + .Characters(cj, 1).text
                            length = length + 1
                        Else
                            Exit For
                        End If
                    Next
                    chgText = chgText + tagStart + tmpText + tagEnd
                    ci = ci + length - 1
                    length = 0
                    mode = 0
                Else
                    chgText = chgText + .Characters(ci, 1).text
                End If
                ci = ci + 1
            Loop
            
            .Value = chgText
            
        End If
    End With
End Sub

ああ、全く持って美しくない(_ _;)/

【2006.05.24】
addTags()だけちょっと改良してみた→ソースはこちら

【2006.05.26】
注釈と背景色のタグ変換対応＆結果をシート毎にCSV形式で自動保存するように修正→ソースはこちら