【Excel】属性をタグに変換後CSV形式で保存

『【Excel】属性指定検索／属性をタグに変換』と『【Excel】属性をタグに変換(ちょっとだけ改善)』との続き。

現在のブックの全シートで、属性をタグに変換後、シート毎にCSV形式で自動保存するようにしてみた。

Sub changeAttribute()
    Dim orgFile As String
    Dim workDir As String
    Dim workFile As String
    Dim saveName As String
    
    orgFile = ActiveWorkbook.FullName
    
    workDir = Replace(ActiveWorkbook.Name, ".xls", "")
    workDir = Replace(workDir, " ", "")
    workDir = Replace(workDir, ".", "-")
    workDir = ActiveWorkbook.Path & "\" & workDir & "-csv"
    If Dir(workDir, vbDirectory) = "" Then
        MkDir workDir
    End If
    
    workFile = workDir & "\_temp_.xls"
    If Dir(workFile, vbArchive) <> "" Then
        Kill workFile
    End If
    ActiveWorkbook.SaveAs workFile

    For Each actSheet In ActiveWorkbook.Worksheets
        actSheet.Activate
        With ActiveSheet
            For Each currentRange In .UsedRange
                currentRange.Activate
                addTags
            Next
            saveName = Replace(.Name, " ", "")
            saveName = Replace(saveName, ".", "-")
            saveName = workDir & "\" & saveName & ".csv"
            If Dir(saveName, vbArchive) <> "" Then
                Kill saveName
            End If
            .SaveAs FileName:=saveName, FileFormat:=xlCSV
'            MsgBox "属性をタグに置換し'" & .saveName & "'の名前で保存しました"
        End With
    Next
    MsgBox "属性をタグに置換し'" & workDir & "'内にCSV形式で保存しました"
    
    curBook = ActiveWorkbook.Name
        
    Workbooks.Open orgFile

    If Dir(workFile, vbArchive) <> "" Then
        Kill workFile
    End If
    
    Workbooks(curBook).Close SaveChanges:=False

End Sub

Sub addTags()
    Dim ColorString As Variant
    ColorString = Array("null", _
        "#000000", "#FFFFFF", "#FF0000", "#00FF00", "#0000FF", "#FFFF00", "#FF00FF", "#00FFFF", _
        "#800000", "#008000", "#000080", "#808000", "#800080", "#008080", "#C0C0C0", "#808080", _
        "#9999FF", "#993366", "#FFFFCC", "#CCFFFF", "#660066", "#FF8080", "#0066CC", "#CCCCFF", _
        "#000080", "#FF00FF", "#FFFF00", "#00FFFF", "#800080", "#800000", "#008080", "#0000FF", _
        "#00CCFF", "#CCFFFF", "#CCFFCC", "#FFFF99", "#99CCFF", "#FF99CC", "#CC99FF", "#FFCC99", _
        "#3366FF", "#33CCCC", "#99CC00", "#FFCC00", "#FF9900", "#FF6600", "#666699", "#969696", _
        "#003366", "#339966", "#003300", "#333300", "#993300", "#993366", "#333399", "#333333" _
    )
    Dim BgColorID As Long
    Dim BgTagStart As String
    Dim BgTagEnd As String
    
    With ActiveCell
        BgColorID = .Interior.ColorIndex
        If 0 < BgColorID And BgColorID <= 56 Then
            BgTagStart = "<bgcolor name=" + Chr(34) + ColorString(BgColorID) + Chr(34) + ">"
            BgTagEnd = "</bgcolor>"
        Else
            BgTagStart = ""
            BgTagEnd = ""
        End If
        addTagsSub BgTagStart, BgTagEnd
        If .NumberFormat <> "General" Then
            .NumberFormat = "General"
        End If
        .Interior.ColorIndex = 0
        .Font.ColorIndex = 0
        .Font.Strikethrough = False
    End With
End Sub

Sub addTagsSub(BgTagStart, BgTagEnd)
    Dim ci As Long, cj As Long, length As Long, mode As Long, orglength As Long
    Dim orgText As String, chgText As String
    
    length = 0
    mode = 0
    isIndent = 1
    With ActiveCell
        If Application.WorksheetFunction.IsText(.Value) = True Then
            orgText = .Value
            chgText = ""
            orglength = Len(orgText)
            For ci = 1 To orglength
                If isIndent = 1 Then
                    If Mid(orgText, ci, 1) <> ">" And _
                       Mid(orgText, ci, 1) <> " " Then
                        If 0 < length Then
                            chgText = Mid(orgText, ci - length, length)
                            length = 0
                        End If
                        chgText = chgText + BgTagStart
                        isIndent = 0
                    End If
                End If
                If isIndent = 0 Then
                    With .Characters(ci, 1).Font
                        If .Strikethrough = True Then
                            mode = 1
                            tagStart = "<del>"
                            tagEnd = "</del>"
                        ElseIf .ColorIndex = 3 Then ' Red
                            mode = 2
                            tagStart = "<add>"
                            tagEnd = "</add>"
                        ElseIf .ColorIndex = 5 Or .ColorIndex = 32 Then ' Blue
                            mode = 3
                            tagStart = "<notice>"
                            tagEnd = "</notice>"
                        End If
                    End With
                End If
                If mode <> 0 Then
                    If 0 < length Then
                        chgText = chgText + Mid(orgText, ci - length, length)
                    End If
                    length = 1
                    For cj = ci + 1 To orglength
                        With .Characters(cj, 1).Font
                            If (mode = 1 And .Strikethrough = True) Or _
                               (mode = 2 And .ColorIndex = 3) Or _
                               (mode = 3 And (.ColorIndex = 5 Or .ColorIndex = 32)) Then
                                length = length + 1
                            Else
                                Exit For
                            End If
                        End With
                    Next
                    chgText = chgText + tagStart + Mid(orgText, ci, length) + tagEnd
                    ci = ci + length - 1
                    length = 0
                    mode = 0
                Else
                    length = length + 1
                End If
            Next
            If 0 < length Then
                chgText = chgText + Mid(orgText, ci - length, length)
            End If
            .Value = chgText + BgTagEnd
        Else
            .Value = BgTagStart & CStr(.Value) & BgTagEnd
        End If
    End With
End Sub

機能的には、

1. ブックのあるフォルダ下に“(ブック名)-csv”というフォルダを作成
2. 各シートの全有効セルについて
   • 取り消し線の付いた文字を<del>～</del>というタグに置換
   • 赤文字は追加とみなし、<add>～</add>というタグに置換
   • 青文字は注意書きとみなし、<notice>～</notice>というタグに置換
   • 背景色を<bgcolor name="#xxxxxx">～</bgcolor>というタグに置換
   という処理を実施(ただし数式が入っているセルは背景色のみ対応)
3. 変換後のシートを、1. で作ったフォルダの下に“(シート名).csv”というファイル名でCSV形式で保存

ということをやってるだけ。

なお、セルのテキスト頭の>はインデントとみなし、bgcolorタグはその後につける

とりあえず形にはなったけれど、遅すぎる……。
文字数が多いセルに対して次のような処理を行っただけで、やたらと時間がかかることが判明。

Sub checkAttribute()
    Dim ci As Long
    Dim ModeStr As String
    
    ModeStr = ""
    
    With ActiveCell
        If Application.WorksheetFunction.IsText(.Value) = True Then
            For ci = 1 To .Characters.Count
                With .Characters(ci, 1).Font
                    If .Strikethrough = True Then
                        ModeStr = ModeStr & "1"
                    ElseIf .ColorIndex = 3 Then
                        ModeStr = ModeStr & "2"
                    ElseIf .ColorIndex = 5 Or .ColorIndex = 32 Then
                        ModeStr = ModeStr & "3"
                    Else
                        ModeStr = ModeStr & "0"
                    End If
                End With
            Next
            MsgBox ModeStr
        End If
    End With
End Sub

どうやら .Characters(locate,length).Font 以下のアクセスがボトルネックらしい……けれど、セル内部の文字列で部分的に属性を変えてあるのをチェックしようとすると、この方法しかないみたいなので、どうしようもないのかな……教えて、えらいひと。

結局、セル属性が保存されるようなテキスト形式で保存したものを加工する方が速度的には断然速そう……問題はその構造を自分で理解して整形するプログラムを書く時間がかかるので、片手間じゃやれない、ってことだけど(_ _;)/

【メモ】
Excel関係でいろいろ調べたい場合、『Shun's Page』が実践的で便利そう。

ツイート