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