Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


137 / 13645 ツリー ←次へ | 前へ→

【81832】セル内の文字色操作 こまおじ 21/6/19(土) 5:30 質問[未読]
【81833】Re:セル内の文字色操作 マナ 21/6/19(土) 14:28 発言[未読]
【81835】Re:セル内の文字色操作 こまおじ 21/6/20(日) 9:54 お礼[未読]
【81836】Re:セル内の文字色操作 マナ 21/6/20(日) 12:21 発言[未読]
【81837】Re:セル内の文字色操作 マナ 21/6/20(日) 17:41 発言[未読]
【81838】Re:セル内の文字色操作 マナ 21/6/20(日) 19:05 発言[未読]
【81839】Re:セル内の文字色操作 こまおじ 21/6/21(月) 2:03 お礼[未読]
【81840】Re:セル内の文字色操作 マナ 21/6/21(月) 21:59 発言[未読]
【81844】Re:セル内の文字色操作 こまおじ 21/6/24(木) 0:51 お礼[未読]
【81834】Re:セル内の文字色操作 マナ 21/6/19(土) 16:03 発言[未読]

【81832】セル内の文字色操作
質問  こまおじ  - 21/6/19(土) 5:30 -

引用なし
パスワード
   教えてください。

セル内の文字が斜体だった場合にのみ、
赤色にするコードを作成したのですが、
先頭文字が斜体で、かつ、ほかの文字が斜体だった場合に、
書式情報が壊れてしまう状態になります。
※セル全体が斜体文字の場合は書式は正常のままです。
具体的な文字列を記載しますと
「123456789」
で「1と3」や「1と9」の状態だと書式情報が壊れます。

これはvba上のバグなのでしょうか?
回避策などがありましたら、教えてください。

以下が作成したコードです。
※対象のセルのアドレスは1,1となっていますが、
 実際は変数でループ処理にしています。

For 開始位置 = 1 To Len(Cells(1, 1))
 If Cells(1, 1).Characters(開始位置, 1).Font.Italic = True Then
  Cells(1, 1).Characters(開始位置, 1).Font.ColorIndex = 3
 End If
Next

【81833】Re:セル内の文字色操作
発言  マナ  - 21/6/19(土) 14:28 -

引用なし
パスワード
   ▼こまおじ さん:

他板ですが、つい先日同様の質問がありました
ただ完全解決ではありません
ht tp://www.excel.studio-kazu.jp/kw/20210616111834.html

【81834】Re:セル内の文字色操作
発言  マナ  - 21/6/19(土) 16:03 -

引用なし
パスワード
   ▼こまおじ さん:

ワードを使ってみました。
1)ワードにコピペ
2)置換で文字色変更
3)エクセルにコピペ

ただこの方法にも以下の問題があります。
・セル内改行があるとだめ
・時間がかかる

【81835】Re:セル内の文字色操作
お礼  こまおじ  - 21/6/20(日) 9:54 -

引用なし
パスワード
   情報提供ありがとうございます。
おかげさまで、VBAのバグということがわかり、
ロジックがまずい訳ではないと分かり助かりました。
そこで、解決方法より回避方法を模索し、
どうやら、回避出来ました。

原因はよくわからないままですが、
リボン上に現れるセルのフォント情報と、
セル内の1文字目のフォント情報が乖離している場合に、
このバグは発生するみたいです。
もう少し、VBAよりに書くと、
Range.Fontのプロパティと
Range.Characters(1, 1).Fontのプロパティの全てが一致していない場合に、
マクロ実行でRange.Characters(1以外, 1).Fontのプロパティの一部をいじると
セル内の書式情報が壊れます。

では、RangeとRange.Characters(1, 1)の情報を合わせればいいと考えるも、
VBA実行時にRange.Characters(1, 1)の情報を退避してから、
Range.Fontのプロパティ情報でプロパティに上書きし、
最後に退避した情報で元に戻してやればいいかと考えたのですが、
Range.FontのプロパティがNULLの場合(フォントサイズ等でありえます)、
データが上書きできずバグります。

詰んだかと思ったんですが、もうひとつのVBAのバグ(仕様?)があり、
Fontの情報を揃えることが出来ました。
やりかたは簡単で、Range.Characters(1, 1).Fontのプロパティを
Range.Characters(1, 1).Fontのプロパティで自身の情報で上書きすると、
Range.Fontのプロパティが自動的に同期をとります。
ただし、文字の上位置と下位置のプロパティは、
どちらか一方しか成り立ちませんので条件分岐が必要になります。

以下、解決したコードを載せておきます。

'RangeのFontプロパティを上書き。Characters(1, 1)の情報を更新するとなぜか更新される。
With Cells(対象行, 対象列).Characters(1, 1).Font
 .Name = Cells(対象行, 対象列).Characters(1, 1).Font.Name
 .FontStyle = Cells(対象行, 対象列).Characters(1, 1).Font.FontStyle
 .Size = Cells(対象行, 対象列).Characters(1, 1).Font.Size
 .Strikethrough = Cells(対象行, 対象列).Characters(1, 1).Font.Strikethrough
 .OutlineFont = Cells(対象行, 対象列).Characters(1, 1).Font.OutlineFont
 .Shadow = Cells(対象行, 対象列).Characters(1, 1).Font.Shadow
 .Underline = Cells(対象行, 対象列).Characters(1, 1).Font.Underline
 .ColorIndex = Cells(対象行, 対象列).Characters(1, 1).Font.ColorIndex
 .TintAndShade = Cells(対象行, 対象列).Characters(1, 1).Font.TintAndShade
 .ThemeFont = Cells(対象行, 対象列).Characters(1, 1).Font.ThemeFont
End With

'NULLがあるため、入れ子ではなく独立して条件の確認を行う。
If Cells(対象行, 対象列).Characters(1, 1).Font.Superscript = True Then
 Cells(対象行, 対象列).Characters(1, 1).Font.Superscript = Cells(対象行, 対象列).Characters(1, 1).Font.Superscript
End If

'NULLがあるため、入れ子ではなく独立して条件の確認を行う。
If Cells(対象行, 対象列).Characters(1, 1).Font.Subscript = True Then
 Cells(対象行, 対象列).Characters(1, 1).Font.Subscript = Cells(対象行, 対象列).Characters(1, 1).Font.Subscript
End If

'斜体文字チェック→赤文字設定
For 開始文字位置 = 1 To Len(対象セル)
 If Cells(対象行, 対象列).Characters(開始文字位置, 1).Font.Italic = True Then
  Cells(対象行, 対象列).Characters(開始文字位置, 1).Font.ColorIndex = 3
 End If
Next

【81836】Re:セル内の文字色操作
発言  マナ  - 21/6/20(日) 12:21 -

引用なし
パスワード
   ▼こまおじ さん:

研究熱心ですね、
1文字目から連続して斜体の場合は失敗するようですが…

【81837】Re:セル内の文字色操作
発言  マナ  - 21/6/20(日) 17:41 -

引用なし
パスワード
   ▼こまおじ さん:

頂いたコメントをヒントに考えてみました
地道に全文字設定し直せばOKのようです。

Sub test()
  Dim i As Long, ary() As Boolean
  Dim c As Range
  
  Set c = Range("A1")
  ReDim ary(1 To Len(c.Characters.Text), 1 To Len(c.Characters.Text))

  For i = 1 To UBound(ary)
    ary(i, 1) = c.Characters(i, 1).Font.Italic
    ary(i, 2) = c.Characters(i, 1).Font.Bold
  Next i
  
  For i = 1 To UBound(ary)
    With c.Characters(i, 1)
      c.Characters(i, 0).Font.Bold = Not ary(i, 2)
      .Font.Italic = ary(i, 1)
      .Font.Bold = ary(i, 2)
    End With
  Next i
  
  For i = 1 To UBound(ary)
    With c.Characters(i, 1)
      If ary(i, 1) Then
        .Font.Color = vbRed
        .Font.Italic = ary(i, 1)
      End If
    End With
  Next i
  
End Sub

【81838】Re:セル内の文字色操作
発言  マナ  - 21/6/20(日) 19:05 -

引用なし
パスワード
   ▼こまおじ さん:

この行は不要でした。

>      c.Characters(i, 0).Font.Bold = Not ary(i, 2)

【81839】Re:セル内の文字色操作
お礼  こまおじ  - 21/6/21(月) 2:03 -

引用なし
パスワード
   ▼マナ さん

丁寧に解説していただきありがとうございます。
教えていただいた方式だと、
1〜2文字目が斜体、取り消し線設定などされていると、
書式情報が壊れてしまう感じですね。

連続文字の際の方、ご指摘ありがとうございます。
検証が足りてませんでした。
連続して斜体になっている文字の検証をしてみたのですが、
結果として、連続文字として処理すればよいことが分かりました。
コードを以下に載せておきます。

ご助言ありがとうございました。
--------------------------------------------------------------
'連続文字かを判定
For 終端 = 2 To Len(Cells(行, 列))
 If Cells(行, 列).Characters(1, 1).Font.Name = Cells(行, 列).Characters(終端, 1).Font.Name And _
  Cells(行, 列).Characters(1, 1).Font.FontStyle = Cells(行, 列).Characters(終端, 1).Font.FontStyle And _
  Cells(行, 列).Characters(1, 1).Font.Size = Cells(行, 列).Characters(終端, 1).Font.Size And _
  Cells(行, 列).Characters(1, 1).Font.Strikethrough = Cells(行, 列).Characters(終端, 1).Font.Strikethrough And _
  Cells(行, 列).Characters(1, 1).Font.OutlineFont = Cells(行, 列).Characters(終端, 1).Font.OutlineFont And _
  Cells(行, 列).Characters(1, 1).Font.Shadow = Cells(行, 列).Characters(終端, 1).Font.Shadow And _
  Cells(行, 列).Characters(1, 1).Font.Underline = Cells(行, 列).Characters(終端, 1).Font.Underline And _
  Cells(行, 列).Characters(1, 1).Font.ColorIndex = Cells(行, 列).Characters(終端, 1).Font.ColorIndex And _
  Cells(行, 列).Characters(1, 1).Font.TintAndShade = Cells(行, 列).Characters(終端, 1).Font.TintAndShade And _
  Cells(行, 列).Characters(1, 1).Font.ThemeFont = Cells(行, 列).Characters(終端, 1).Font.ThemeFont Then
 Else
  Exit For
 End If
Next
'
If 終端 > Len(Cells(行, 列)) Then
 文字長 = 1
Else
 文字長 = 終端 - 1
End If

'RangeのFontプロパティを上書き。Characters(1, 連続文字長)の情報を更新するとなぜか更新される。
With Cells(行, 列).Characters(1, 文字長).Font
  .Name = Cells(行, 列).Characters(1, 文字長).Font.Name
  .FontStyle = Cells(行, 列).Characters(1, 文字長).Font.FontStyle
  .Size = Cells(行, 列).Characters(1, 文字長).Font.Size
  .Strikethrough = Cells(行, 列).Characters(1, 文字長).Font.Strikethrough
  .OutlineFont = Cells(行, 列).Characters(1, 文字長).Font.OutlineFont
  .Shadow = Cells(行, 列).Characters(1, 文字長).Font.Shadow
  .Underline = Cells(行, 列).Characters(1, 文字長).Font.Underline
  .ColorIndex = Cells(行, 列).Characters(1, 文字長).Font.ColorIndex
  .TintAndShade = Cells(行, 列).Characters(1, 文字長).Font.TintAndShade
  .ThemeFont = Cells(行, 列).Characters(1, 文字長).Font.ThemeFont
End With

'NULLがあるため、入れ子ではなく独立して条件の確認を行う。
If Cells(行, 列).Characters(1, 文字長).Font.Superscript = True Then
 Cells(行, 列).Characters(1, 文字長).Font.Superscript = Cells(行, 列).Characters(1, 文字長).Font.Superscript
End If
'NULLがあるため、入れ子ではなく独立して条件の確認を行う。
If Cells(行, 列).Characters(1, 文字長).Font.Subscript = True Then
 Cells(行, 列).Characters(1, 文字長).Font.Subscript = Cells(行, 列).Characters(1, 文字長).Font.Subscript
End If

'斜体文字チェック→赤文字設定
For 開始文字位置 = 1 To Len(セル)
 If Cells(行, 列).Characters(開始文字位置, 1).Font.Italic = True Then
  Cells(行, 列).Characters(開始文字位置, 1).Font.ColorIndex = 3
 End If
Next

【81840】Re:セル内の文字色操作
発言  マナ  - 21/6/21(月) 21:59 -

引用なし
パスワード
   ▼こまおじ さん:

>1〜2文字目が斜体、取り消し線設定などされていると、
>書式情報が壊れてしまう感じですね。

さすがに、それは確認済みというか、承知のうえの回答でしたが…

ただ全文字で再設定する必要ないというのは、
ご指摘の通りで、これに関しては、全く考えていませんでした。

【81844】Re:セル内の文字色操作
お礼  こまおじ  - 21/6/24(木) 0:51 -

引用なし
パスワード
   お礼が遅れて申し訳ありません。

わざわざ時間を割いて検証いただきまして、
ありがとうございました。

137 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free