| |
ichinoseさん、ご回答ありがとうございます。
早速試してみました。が、単独で用いるとうまく動作するのですが、
既存のプログラムに組み込むとループが行われなくなりました。
(最初の文字列だけ色が変わる)
小生はＶＢＡ初心者で、問題点がよくわかりません。すみませんが、
全体を載せておきますので、もし原因がお分かりでしたら指摘して
いただけないでしょうか？
何度も申し訳ありませんが、よろしくお願い致します。
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
|
|
- 03/12/17(水) 18:28 -
