アクティブシートをコピーして検索文字列の色を変更する

2017–09–19 (Tue) 07:37
おはようございます。
今日のマクロはアクティブシートをコピーし、検索文字列を指定。その後色を変更すると言うマクロです。私はたまに使うのですが、一般的にどのぐらい使うのかな……?と言う感じです;;;
Ctrl+Fは使い勝手の悪いときも有りますし、そう言うときはこっちの方が便利なのです……。

Sub アクティブシートをコピーして検索文字列の赤色にする()
Dim buf As String, MaxRow As Long, MaxCol As Long
buf = InputBox("名前を入力してください")
Application.ScreenUpdating = False
ActiveWorkbook.ActiveSheet.Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
Dim i As Long, j As Long
Dim ken As Variant
ken = Range(Cells(1, 1), Cells(MaxRow, MaxCol))
For i = 1 To MaxRow
For j = 1 To MaxCol
If InStr(ken(i, j), buf) <> 0 Then
Cells(i, j).Characters(Start:=InStr(ken(i, j), buf), Length:=Len(buf)).Font.ColorIndex = 3
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Sub アクティブシートをコピーして検索文字列の青色にする()
Dim buf As String, MaxRow As Long, MaxCol As Long
buf = InputBox("名前を入力してください")
Application.ScreenUpdating = False
ActiveWorkbook.ActiveSheet.Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
Dim i As Long, j As Long
Dim ken As Variant
ken = Range(Cells(1, 1), Cells(MaxRow, MaxCol))
For i = 1 To MaxRow
For j = 1 To MaxCol
If InStr(ken(i, j), buf) <> 0 Then
Cells(i, j).Characters(Start:=InStr(ken(i, j), buf), Length:=Len(buf)).Font.ColorIndex = 5
End If
Next
Next
Application.ScreenUpdating = True
End Sub

Sub アクティブシートをコピーして検索文字列の緑色にする()
Dim buf As String, MaxRow As Long, MaxCol As Long
buf = InputBox("名前を入力してください")
Application.ScreenUpdating = False
ActiveWorkbook.ActiveSheet.Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
Dim i As Long, j As Long
Dim ken As Variant
ken = Range(Cells(1, 1), Cells(MaxRow, MaxCol))
For i = 1 To MaxRow
For j = 1 To MaxCol
If InStr(ken(i, j), buf) <> 0 Then
Cells(i, j).Characters(Start:=InStr(ken(i, j), buf), Length:=Len(buf)).Font.ColorIndex = 10
End If
Next
Next
Application.ScreenUpdating = True
End Sub

Sub アクティブシートをコピーして検索文字列の黄色にする()
Dim buf As String, MaxRow As Long, MaxCol As Long
buf = InputBox("名前を入力してください")
Application.ScreenUpdating = False
ActiveWorkbook.ActiveSheet.Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
Dim i As Long, j As Long
Dim ken As Variant
ken = Range(Cells(1, 1), Cells(MaxRow, MaxCol))
For i = 1 To MaxRow
For j = 1 To MaxCol
If InStr(ken(i, j), buf) <> 0 Then
Cells(i, j).Characters(Start:=InStr(ken(i, j), buf), Length:=Len(buf)).Font.ColorIndex = 27
End If
Next
Next
Application.ScreenUpdating = True
End Sub

弾きたい~~~

日々の聖句読むマクロ

2017–09–17 (Sun) 20:07
無題

自分用の日々の聖句を読むマクロです
日付が変わって起動すると自動で日々の聖句も変わってくれます(^∇^)ノ
使いやすっ
この程度の単純なマクロでも作って頂くとお金が結構かかるのです。数万ぐらいは取られてしまうね。

日々の聖句読むマクロ

期間(~まで)マクロも修正されました。

2017–09–14 (Thu) 18:50
Function KaramadeR(開始 As Range, 終わり As Range)
Dim k, kai
For Each k In 開始
If k <> 0 Then
kai = kai & k
End If
Next
Dim owa
For Each k In 終わり
If k <> 0 Then
owa = owa & k
End If
Next
If kai = "" Or owa = "" Then
KaramadeR = ""
ElseIf kai = "年月" Or owa = "年月" Then
KaramadeR = ""
Else
kai = Replace(kai, ".", "/")
owa = Replace(owa, ".", "/")
kai = Replace(kai, "から", "")
owa = Replace(owa, "まで", "")
KaramadeR = DateDiff("m", kai, owa) + 1
End If
End Function
Function KikanMonthR(開始 As Range, 終わり As Range)
Dim k, kai
For Each k In 開始
If k <> 0 Then
kai = kai & k
End If
Next
Dim owa
For Each k In 終わり
If k <> 0 Then
owa = owa & k
End If
Next
If kai = "" Or owa = "" Then
KikanMonthR = ""
ElseIf kai = "年月" Or owa = "年月" Then
KikanMonthR = ""
Else
kai = Replace(kai, ".", "/")
owa = Replace(owa, ".", "/")
KikanMonthR = DateDiff("m", kai, owa) + 1
End If


End Function

期間が入力されていない場合、自動で空白にしてくれます。
早速活用していますよ~~~。
皆様も是非ご活用下さい!!!

名前の範囲を検索し、他の範囲から文字列を取得する

2017–09–14 (Thu) 07:44
名前の範囲を検索し、他の範囲から文字列を取得するマクロです。

Function Sget(名前 As String, 検索範囲名 As Range, 取得範囲名 As Range)
On Error Resume Next
basyo = WorksheetFunction.Match(名前, Range(検索範囲名), 0)
On Error GoTo 0
If basyo <> 0 Then
Sget = WorksheetFunction.Index(Range(取得範囲名), basyo)
Else
Sget = ""
End If
End Function

期間・年月日マクロ

2017–09–13 (Wed) 19:05
今日は期間や年月日のマクロを作成致します。

無題

Function KikanMonthR(開始 As Range, 終わり As Range)
Dim k, kai
For Each k In 開始
If k <> 0 Then
kai = kai & k
End If
Next
Dim owa
For Each k In 終わり
If k <> 0 Then
owa = owa & k
End If
Next
kai = Replace(kai, ".", "/")
owa = Replace(owa, ".", "/")
KikanMonthR = DateDiff("m", kai, owa) + 1
End Function

KikanMonth

Function KikanMonth(開始 As String, 終わり As String)
開始 = Replace(開始, ".", "/")
終わり = Replace(終わり, ".", "/")
KikanMonth = DateDiff("m", 開始, 終わり) + 1
End Function

年月日

Function 年月日(年 As String, 月 As String, Optional 日 As String)
If 日 = "" Then
日 = 1
End If
年月日 = 年 & "/" & 月 & "/" & 日
End Function


「日」が入っていない場合はこの関数で日を追加、元号、和暦、月を表示するようにしましょう。
無題


gengoNGK
Function gengoNGK(期間 As String)
gengoNGK = WorksheetFunction.Text(CDate(期間 & "1日"), "g")
End Function

GenyearNGK
Function GenyearNGK(期間 As String)
GenyearNGK = WorksheetFunction.Text(CDate(期間 & "1日"), "e")
End Function

monthNGK
Function monthNGK(期間 As String)
monthNGK = WorksheetFunction.Text(CDate(期間 & "1日"), "m")
End Function

« 前へ | HOME |  次へ »

プロフィール

あゆみ

Author:あゆみ
FC2ブログへようこそ!

最新記事

最新コメント

フリーエリア

月別アーカイブ

カテゴリ

ブロとも申請フォーム

検索フォーム

RSSリンクの表示

リンク