Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : 指定なし)
セル内文字列の変換時、もとの文字色を変えたくない。
投稿日時: 21/08/13 13:05:13
投稿者: tarima

1つのセル内に
---------------------------
123
ABC
いいいい赤字うううううう
---------------------------
のように、複数行の文字列があります。
"赤字"部分のみ赤字です。他は黒字です。
 
シート内の全セル文字列内の英数カナを半角に変換時、セル内の赤字が黒字になってしまいます。
UsedRangeをLoopして、以下のどちらでも結果は同じです。
rng.Value = WorksheetFunction.Asc(rng.Value)
rng.Value = StrConv(rng.Value, vbNarrow)
 
一部の文字色を変えたくないのですが、方法はありますか。
 
よろしくお願いします。

回答
投稿日時: 21/08/13 15:02:08
投稿者: simple

最初に思いつくのは、元の文字列の赤字部分の位置を記憶しておき、
変換後にそれを用いて赤字に修正することです。
ただ、濁音半濁音などがあると文字位置が狂ってきます。(ダは1文字、ダは2文字)
試していないがうまくいかなそうです。
 
少しトリッキーな手法ですが、こんな手法があります。

Sub test()
    Dim rng As Range
    Dim s As String
    
    Set rng = [A1]  '例
    s = rng.Value(xlRangeValueXMLSpreadsheet)
    rng.Offset(, 1).Value(xlRangeValueXMLSpreadsheet) = StrConv(s, vbNarrow)
End Sub

確認用に右セルに書き出しています。
OKであれば、もちろん上書きして問題ありません。
UsedRangeの""ではない各セルに対して走査する拡張はそちらでやってください。

回答
投稿日時: 21/08/13 16:46:33
投稿者: WinArrow
投稿者のウェブサイトに移動

カナ文字を半角にする
ので、文字位置では、難しいでしょうね・・・・
 
"赤字"の文字を変数(複数あれば配列)に記憶し、半角にしておきます。
 
セル1つのみの変換コードです。

Sub test()
Dim 赤字, a As Long, flg As Boolean, data As Range, i As Long
    ReDim 赤字(0)
    a = 0
    flg = False
    Set data = Range("A1")
    
    For i = 1 To Len(data.Value)
        If data.Characters(i, 1).Font.Color = vbRed Then
            flg = True
        Else
            flg = False
        End If
        If flg Then
            ReDim Preserve 赤字(a)
            赤字(a) = 赤字(a) & StrConv(Mid(data, i, 1), vbNarrow)
        Else
            If i > 1 Then
                If data.Characters(i - 1, 1).Font.Color <> data.Characters(i, 1).Font.Color Then
                    a = a + 1
                End If
            End If
        End If
    Next
    data.Value = StrConv(data.Value, vbNarrow)
    
    For a = LBound(赤字) To UBound(赤字)
        i = InStr(data.Value, 赤字(a))
        data.Characters(i, Len(赤字(a))).Font.Color = vbRed
    Next

End Sub

回答
投稿日時: 21/08/13 18:43:58
投稿者: simple

たらのりさんからフォントが変わってしまうという指摘をいただきました。
ありがとうございました。
ご指摘のとおりです。
 
XMLSpreadsheet形式の文字列のなかにFont指定がありますので、
その指定文字列自体が半角化の影響を受けてしまいますね、確かに。
"最も近い"Font種類が適用されるので、影響は少ない気もしますが、
影響が甚大なら、変更前のFont指定を保存しておいて復旧するんでしょうか。
複数のものが混在していたら。。。。。面倒かな。(下記注参考)
 
余談ですが、この手法は他の掲示板で教えてもらったものです。
("取り消し線"が指定された箇所を一括して削除したい、という話。
 XMLSpreadsheet形式で取り出し正規表現で一括して置換して戻すということで、
 charactersで判別するより100倍近い高速化が図られたという話でした。)
 
(注)
もっとも今回の話でも、正規表現を使って、 > と </FONT>の間の文字列だけを
半角化の対象にするように変更すれば、フォント指定文字の半角化は回避できるとは思います。
複雑化するので提示はしませんが。

回答
投稿日時: 21/08/13 19:08:10
投稿者: たらのり

simple さん、すみませんでした。
レスを削除してしまいました。
 
simple さんのコード、とても不思議で、なぜ文字列の s に属性が
紐づいているのかと思ったら……
 
大変興味深く拝見いたしました。
 

回答
投稿日時: 21/08/13 20:01:19
投稿者: simple

Valueプロパティが引数を持っているんですかね。
 
ご承知のとおり、現在のOfficeは基本的にXMLをzip形式にまとめたもので、
内部構造はXMLで記載されているようです。
xlRangeValueXMLSpreadsheetを指定したValueプロパティは、
その内部構造に近いものをそのまま返してくるので、結構読み書きも高速です。
その後の処理は、基本的に文字列の操作だけになるので、高速化の余地がでてきます。
 
一方で、charactersというのはXML構造と乖離しているのか、結構動作は緩慢です。
一文字ごとの判定処理は時に大量の時間を要すことがあります。
大量の文字列のcharactersを使った処理も、XMLで代替できるものについては、
その手法をとることで高速化が図れることもあるようです。

回答
投稿日時: 21/08/13 23:55:30
投稿者: たらのり

> simple さん
 
問題によっては(Characters を使用する場合と比較して)向き不向きも
あるかもしれませんが,今回の件にはバチッと当てはまる解法ですね。
 
トリッキーとありますが,ひと言ことわりがあればそんなこともなく。
 
(飲みながらニヤニヤしてますww)
 

回答
投稿日時: 21/08/14 07:30:42
投稿者: simple

コメントありがとうございます。
 
前のバージョンはフォント名も半角化されていましたが、
正規表現を利用しなくとも、比較的簡単なコードで回避できました。
【前提】
123
ABC
いいいいABCうううううう
の3行分がひとつのセルにあるとします。
 
【使用法】
下記のコードを実行すると、
英数カナを半角化し、同時に
そのセルの書式(文字色のほか、太字、
イタリック、フォントの大きさ等)が保持されます。
 
・1セルを対象としたテスト版と、
・シート全体に対するもの
の二つを示しました。
 
以下、参考コードです。

Rem   XMLSpreadsheet形式文字列を利用し、
Rem   書式を保存したまま、半角化StrConv(,vbNarrow)を実行
Sub test()
    Dim rng     As Range

    'テスト(A1セルを置換して、B1に結果を書込ます)
    Set rng = [A1]
    rng.Offset(, 1).Value(xlRangeValueXMLSpreadsheet) = myConvert(rng)

    '本番(自分自身を書換)
'    For Each rng In ActiveSheet.UsedRange
'        If rng.Value <> "" Then
'            rng.Value(xlRangeValueXMLSpreadsheet) = myConvert(rng)
'        End If
'    Next
End Sub

Function myConvert(rng As Range) As String
    Dim s$, target$
    Dim ary1 As Variant, ary2 As Variant
    
    'XMLSpreadsheet形式の文字列を、
    '  ...<Cell....</Cell>... に三分割し、中間のセルタグ部分についてだけ置換する
    
    s = rng.Value(xlRangeValueXMLSpreadsheet)
    '分解
    ary1 = Split(s, "<Cell")
    ary2 = Split(ary1(1), "</Cell>")
    target = ary2(0)
    '置換
    target = StrConv(target, vbNarrow)
    '復元
    target = Join(Array(target, ary2(1)), "</Cell>")
    myConvert = Join(Array(ary1(0), target), "<Cell")
End Function

投稿日時: 21/08/14 10:32:24
投稿者: tarima

 
WinArrowさん、1文字ずつ見る、配列に入れていく、大変勉強になりました。ありがとうございます。
 
simpleさん、まさにシンプルで美しいコードをありがとうございます。
xlRangeValueXMLSpreadsheetを指定したValueプロパティを初めて見ました。
完璧に希望どおり実現できました。希望以上です。
詳しい説明、テスト用のコードまで入れてくださり、ありがとうございます。
[/code]