Excel VBA質問箱 IV

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

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


12572 / 13644 ツリー ←次へ | 前へ→

【9824】特定の文字列の色の変更。 ひゅーが 03/12/17(水) 18:28 質問
【9828】Re:特定の文字列の色の変更。 ichinose 03/12/17(水) 20:34 回答
【9830】Re:特定の文字列の色の変更 訂正 ichinose 03/12/17(水) 21:14 発言
【9831】Re:特定の文字列の色の変更。 ひゅーが 03/12/18(木) 0:30 お礼
【9833】Re:特定の文字列の色の変更。 ichinose 03/12/18(木) 8:57 発言
【9839】Re:特定の文字列の色の変更。 Kein 03/12/18(木) 11:40 回答
【9840】Re:特定の文字列の色の変更。 ひゅーが 03/12/18(木) 12:43 お礼

【9824】特定の文字列の色の変更。
質問  ひゅーが E-MAIL  - 03/12/17(水) 18:28 -

引用なし
パスワード
   はじめまして。
早速なのですが、質問させていただきます。
すでにシートに入力されたデータの中で、特定の文字列(複数)の色を変更したいのですが、
どなたかよい方法をご存じないでしょうか。
いろいろ試してみたんですが、なかなかうまくいかず困っています。
みなさんのお知恵を貸していただけるとさいわいです。
よろしくお願いします。

【9828】Re:特定の文字列の色の変更。
回答  ichinose  - 03/12/17(水) 20:34 -

引用なし
パスワード
   ▼ひゅーが さん:
こんばんは。
>すでにシートに入力されたデータの中で、特定の文字列(複数)の色を変更したいのですが、
>どなたかよい方法をご存じないでしょうか。
>いろいろ試してみたんですが、なかなかうまくいかず困っています。
>みなさんのお知恵を貸していただけるとさいわいです。
>よろしくお願いします。
以下の例は、保護などされていないアクティブシートに対しての例です
'========================================================
Sub main()
  Dim rng As Range
  Dim 開始 As Range
  Dim 色かえる文字列 As String
  色かえる文字列 = "abc" '例では、abcという文字列の色を変更します
  Set 開始 = Cells.SpecialCells(xlCellTypeLastCell)
  Set rng = find_rng(開始, Cells, 色かえる文字列)
  Do While Not rng Is Nothing '指定文字列が含まれるセルがある間ループ
   
    Call chg_char_color(rng, 色かえる文字列, 4, True)
    '    ↑色を変える処理
    Set rng = find_rng(開始)
    '  次の検索
    Loop
End Sub
'====================================================================
Function find_rng(開始 As Range, Optional 検索範囲 As Range = Nothing, Optional fwd = "") As Range
'input 検索範囲: 省略可能 検索するセル範囲
'    fwd  : 省略可能 検索する文字、数値
'input-output 開始 : 検索開始セルを指定する最初は、最後のセルを指定する
'           2回目以降は、サブルーチンがi/oに使用する
'output find_rng :検索した結果条件にあったセル。尚、見つからない場合、もしくは、一通り、検索が終了した場合は、nothingが入る
  Static sv検索範囲 As Range
  Static svfwd
  Static first_fd As Range
  Dim fd As Range
  If Not 検索範囲 Is Nothing Then
    Set sv検索範囲 = 検索範囲
    svfwd = fwd
    Set first_fd = Nothing
    End If
  With sv検索範囲
   If first_fd Is Nothing Then
     Set fd = .Find(svfwd, 開始, LookIn:=xlValues, MatchCase:=True, MatchByte:=True)
     Set first_fd = fd
     Set 開始 = fd
     Set find_rng = fd
   Else
     Set fd = .FindNext(開始)
     If Not Intersect(first_fd, fd) Is Nothing Then
      Set find_rng = Nothing
     Else
      Set 開始 = fd
      Set find_rng = fd
      End If
     End If
   End With
End Function
'=====================================================================
Function chg_char_color(rng As Range, col_str As String, color_idx As Long, Optional whole As Boolean = False) As Long
'指定されたセルの指定された文字列を指定されたカラーインデックスの色に変える
'input rng : 文字列の入ったセル
'   col_str:色を変更する文字列
'   color_idx :カラーインデックス
'   whole: true 複数個の文字列の色変更,false 最初だけ変更(規定値)
  Dim st As Long
  Dim c_len As Long
  st = 1
  c_len = Len(col_str)
  Do While st < Len(rng.Value)
    st = InStr(st, rng.Value, col_str)
    If st > 0 Then
     With rng.Characters(Start:=st, Length:=c_len).Font
       .ColorIndex = color_idx
       End With
     st = st + c_len
     If whole = False Then Exit Do
    Else
     Exit Do
     End If
    Loop
End Function

確認してみて下さい。

【9830】Re:特定の文字列の色の変更 訂正
発言  ichinose  - 03/12/17(水) 21:14 -

引用なし
パスワード
   >▼ひゅーが さん:
>こんばんは。
>>すでにシートに入力されたデータの中で、特定の文字列(複数)の色を変更したいのですが、
>>どなたかよい方法をご存じないでしょうか。
>>いろいろ試してみたんですが、なかなかうまくいかず困っています。
>>みなさんのお知恵を貸していただけるとさいわいです。
>>よろしくお願いします。
>以下の例は、保護などされていないアクティブシートに対しての例です
>'========================================================
>Sub main()
>  Dim rng As Range
>  Dim 開始 As Range
>  Dim 色かえる文字列 As String
>  色かえる文字列 = "abc" '例では、abcという文字列の色を変更します
>  Set 開始 = Cells.SpecialCells(xlCellTypeLastCell)
>  Set rng = find_rng(開始, Cells, 色かえる文字列)
>  Do While Not rng Is Nothing '指定文字列が含まれるセルがある間ループ
>   
>    Call chg_char_color(rng, 色かえる文字列, 4, True)
>    '    ↑色を変える処理
>    Set rng = find_rng(開始)
>    '  次の検索
>    Loop
>End Sub
>'====================================================================
>Function find_rng(開始 As Range, Optional 検索範囲 As Range = Nothing, Optional fwd = "") As Range
>'input 検索範囲: 省略可能 検索するセル範囲
>'    fwd  : 省略可能 検索する文字、数値
>'input-output 開始 : 検索開始セルを指定する最初は、最後のセルを指定する
>'           2回目以降は、サブルーチンがi/oに使用する
>'output find_rng :検索した結果条件にあったセル。尚、見つからない場合、もしくは、一通り、検索が終了した場合は、nothingが入る
>  Static sv検索範囲 As Range
>  Static svfwd
>  Static first_fd As Range
>  Dim fd As Range
>  If Not 検索範囲 Is Nothing Then
>    Set sv検索範囲 = 検索範囲
>    svfwd = fwd
>    Set first_fd = Nothing
>    End If
>  With sv検索範囲
>   If first_fd Is Nothing Then
>     Set fd = .Find(svfwd, 開始, LookIn:=xlValues, MatchCase:=True, MatchByte:=True)
>     Set first_fd = fd
>     Set 開始 = fd
>     Set find_rng = fd
>   Else
>     Set fd = .FindNext(開始)
>     If Not Intersect(first_fd, fd) Is Nothing Then
>      Set find_rng = Nothing
>     Else
>      Set 開始 = fd
>      Set find_rng = fd
>      End If
>     End If
>   End With
>End Function
>'=====================================================================
>Function chg_char_color(rng As Range, col_str As String, color_idx As Long, Optional whole As Boolean = False) As Long
>'指定されたセルの指定された文字列を指定されたカラーインデックスの色に変える
>'input rng : 文字列の入ったセル
>'   col_str:色を変更する文字列
>'   color_idx :カラーインデックス
>'   whole: true 複数個の文字列の色変更,false 最初だけ変更(規定値)
>  Dim st As Long
>  Dim c_len As Long
>  st = 1
>  c_len = Len(col_str)
  Do While st <= Len(rng.Value)
>    st = InStr(st, rng.Value, col_str)
>    If st > 0 Then
>     With rng.Characters(Start:=st, Length:=c_len).Font
>       .ColorIndex = color_idx
>       End With
>     st = st + c_len
>     If whole = False Then Exit Do
>    Else
>     Exit Do
>     End If
>    Loop
>End Function
>
>確認してみて下さい。

【9831】Re:特定の文字列の色の変更。
お礼  ひゅーが E-MAIL  - 03/12/18(木) 0:30 -

引用なし
パスワード
   ichinoseさん、ご回答ありがとうございます。
早速試してみました。が、単独で用いるとうまく動作するのですが、
既存のプログラムに組み込むとループが行われなくなりました。
(最初の文字列だけ色が変わる)
小生はVBA初心者で、問題点がよくわかりません。すみませんが、
全体を載せておきますので、もし原因がお分かりでしたら指摘して
いただけないでしょうか?
何度も申し訳ありませんが、よろしくお願い致します。

Private Sub CommandButton1_Click()
  Columns("A:H").Select
  Range("A1").Activate
  ActiveSheet.Unprotect
  Range("A15000").Value = 読み仮名.Text
  Range("B15000").Value = 接頭語.Text
  Range("C15000").Value = 化合物名.Text
  Range("D15000").Value = 包装.Text
  Range("E15000").Value = 単位.Text
  Range("F15000").Value = 本数.Text
  Range("G15000").Value = 特記事項.Text
  Range("H15000").Value = 保管場所.Text
  Range("A7:H15000").Select
    Selection.Sort Key1:=Range("A7"), Order1:=xlAscending, Key2:=Range("C7") _
    , Order2:=xlAscending, Key3:=Range("B7"), Order3:=xlAscending, Header:= _
    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    SortMethod:=xlPinYin
 
  Dim rng As Range
  Dim 開始 As Range
  Dim 色かえる文字列 As String
  色かえる文字列 = "有害"
  Set 開始 = Cells.SpecialCells(xlCellTypeLastCell)
  Set rng = find_rng(開始, Cells, 色かえる文字列)
  Do While Not rng Is Nothing
    Call chg_char_color(rng, 色かえる文字列, 3, True)
    Set rng = find_rng(開始)
    Loop
End Sub
Function find_rng(開始 As Range, Optional 検索範囲 As Range = Nothing, Optional fwd = "") As Range
  Static sv検索範囲 As Range
  Static svfwd
  Static first_fd As Range
  Dim fd As Range
  If Not 検索範囲 Is Nothing Then
    Set sv検索範囲 = 検索範囲
    svfwd = fwd
    Set first_fd = Nothing
    End If
  With sv検索範囲
   If first_fd Is Nothing Then
     Set fd = .Find(svfwd, 開始, LookIn:=xlValues, MatchCase:=True, MatchByte:=True)
     Set first_fd = fd
     Set 開始 = fd
     Set find_rng = fd
   Else
     Set fd = .FindNext(開始)
     If Not Intersect(first_fd, fd) Is Nothing Then
      Set find_rng = Nothing
     Else
      Set 開始 = fd
      Set find_rng = fd
      End If
     End If
   End With
End Function
Function chg_char_color(rng As Range, col_str As String, color_idx As Long, Optional whole As Boolean = False) As Long
  Dim st As Long
  Dim c_len As Long
  st = 1
  c_len = Len(col_str)
  Do While st < Len(rng.Value)
    st = InStr(st, rng.Value, col_str)
    If st > 0 Then
     With rng.Characters(Start:=st, Length:=c_len).Font
       .ColorIndex = color_idx
       End With
     st = st + c_len
     If whole = False Then Exit Do
    Else
     Exit Do
     End If
    Loop
  ActiveSheet.Protect
  Unload Me
End Function

【9833】Re:特定の文字列の色の変更。
発言  ichinose  - 03/12/18(木) 8:57 -

引用なし
パスワード
   ▼ひゅーが さん:
おはようございます。

>早速試してみました。が、単独で用いるとうまく動作するのですが、
>既存のプログラムに組み込むとループが行われなくなりました。
>(最初の文字列だけ色が変わる)
>小生はVBA初心者で、問題点がよくわかりません。すみませんが、
>全体を載せておきますので、もし原因がお分かりでしたら指摘して
>いただけないでしょうか?
>何度も申し訳ありませんが、よろしくお願い致します。
ユーザーフォームのモジュールに貼り付けたと言う事ですね?

>Private Sub CommandButton1_Click()
>  Columns("A:H").Select
>  Range("A1").Activate
>  ActiveSheet.Unprotect
>  Range("A15000").Value = 読み仮名.Text
>  Range("B15000").Value = 接頭語.Text
>  Range("C15000").Value = 化合物名.Text
>  Range("D15000").Value = 包装.Text
>  Range("E15000").Value = 単位.Text
>  Range("F15000").Value = 本数.Text
>  Range("G15000").Value = 特記事項.Text
>  Range("H15000").Value = 保管場所.Text
>  Range("A7:H15000").Select
>    Selection.Sort Key1:=Range("A7"), Order1:=xlAscending, Key2:=Range("C7") _
>    , Order2:=xlAscending, Key3:=Range("B7"), Order3:=xlAscending, Header:= _
>    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
>    SortMethod:=xlPinYin
> 
>  Dim rng As Range
>  Dim 開始 As Range
>  Dim 色かえる文字列 As String
>  色かえる文字列 = "有害"
>  Set 開始 = Cells.SpecialCells(xlCellTypeLastCell)
>  Set rng = find_rng(開始, Cells, 色かえる文字列)
>  Do While Not rng Is Nothing
>    Call chg_char_color(rng, 色かえる文字列, 3, True)
>    Set rng = find_rng(開始)
>    Loop
  ActiveSheet.Protect
  Unload Me
' 上2行は、ここに記述して下さい
' ループ内のFunctionに記述してしまうとそこで終わってしまいます
>End Sub


>Function find_rng(開始 As Range, Optional 検索範囲 As Range = Nothing, Optional fwd = "") As Range
>  Static sv検索範囲 As Range
>  Static svfwd
>  Static first_fd As Range
>  Dim fd As Range
>  If Not 検索範囲 Is Nothing Then
>    Set sv検索範囲 = 検索範囲
>    svfwd = fwd
>    Set first_fd = Nothing
>    End If
>  With sv検索範囲
>   If first_fd Is Nothing Then
>     Set fd = .Find(svfwd, 開始, LookIn:=xlValues, MatchCase:=True, MatchByte:=True)
>     Set first_fd = fd
>     Set 開始 = fd
>     Set find_rng = fd
>   Else
>     Set fd = .FindNext(開始)
>     If Not Intersect(first_fd, fd) Is Nothing Then
>      Set find_rng = Nothing
>     Else
>      Set 開始 = fd
>      Set find_rng = fd
>      End If
>     End If
>   End With
>End Function


>Function chg_char_color(rng As Range, col_str As String, color_idx As Long, Optional whole As Boolean = False) As Long
>  Dim st As Long
>  Dim c_len As Long
>  st = 1
>  c_len = Len(col_str)
  Do While st <= Len(rng.Value)
'         ↑「=」入れといてください
>    st = InStr(st, rng.Value, col_str)
>    If st > 0 Then
>     With rng.Characters(Start:=st, Length:=c_len).Font
>       .ColorIndex = color_idx
>       End With
>     st = st + c_len
>     If whole = False Then Exit Do
>    Else
>     Exit Do
>     End If
>    Loop
>  ActiveSheet.Protect
>  Unload Me
'  上2行削除
>End Function

【9839】Re:特定の文字列の色の変更。
回答  Kein  - 03/12/18(木) 11:40 -

引用なし
パスワード
   これでどうでしょーか ? A:H列のみ検索します。

Private Sub CommandButton1_Click()
  Dim FR As Range
  Dim Ad As String, i As Integer
  Dim ObjRE As Object, Matches As Object, Match As Object
  
  With ActiveSheet
    If .ProtectContents Then .Unprotect
    .UsedRange.Font.ColorIndex = xlColorIndexAutoMatic
  End With
  Range("A15000").Value = 読み仮名.Text
  Range("B15000").Value = 接頭語.Text
  Range("C15000").Value = 化合物名.Text
  Range("D15000").Value = 包装.Text
  Range("E15000").Value = 単位.Text
  Range("F15000").Value = 本数.Text
  Range("G15000").Value = 特記事項.Text
  Range("H15000").Value = 保管場所.Text
  Range("A7:H15000").Sort Key1:=Range("A7"), Order1:=xlAscending, _
  Key2:=Range("C7"), Order2:=xlAscending, Key3:=Range("B7"), _
  Order3:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
  MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
  Set FR = Range("A:H").Find("*有害*", , xlValues)
  If FR Is Nothing Then
    MsgBox "検索値 [有害] は見つかりません", 64
    Exit Sub
  Else
    Ad = FR.Address
  End If
  Set ObjRE = CreateObject("VBScript.RegExp")
  With ObjRE
    .Pattern = "[有害]"
    .Global = True
  End With
  Do
    Set FR = Range("A:H").FindNext(FR)
    Set Matches = ObjRE.Execute(FR.Value)
    For Each Match In Matches
     i = Match.FirstIndex + 1
     FR.Characters(i, 1).Font.ColorIndex = 3
    Next
    Set Matches = Nothing
  Loop Until FR.Address = Ad
  Set FR = Nothing: Set ObjRE = Nothing
End Sub

【9840】Re:特定の文字列の色の変更。
お礼  ひゅーが E-MAIL  - 03/12/18(木) 12:43 -

引用なし
パスワード
   ichinoseさん、Keinさん、ありがとうございます。
おふたりのご指摘・アイデアを組み合わせて、なんとかうまく動くように
なりました。
また質問させていただくこともあるかもしれませんが、そのときはよろしく
お願いします。
本当にありがとうございました。

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