文章の目視確認を効率化
特定のキーワード毎に本文に登場した分だけ文字色を変えて見たいニーズがあり作成。
最初はキーワードが最初に登場した部分だけ文字色を変えていたのを全部変わるように改善。
UserFormは適当に作成して選択したファイルを編集して上書き保存。
色は6色ループとこれまた適当なのでお好きにカスタマイズ可能。
UserForm.bas
Private Sub UserForm_Initialize()
パスラベル.Caption = ""
シートコンボボックス.Clear
シートコンボボックス.Enabled = False
項目コンボボックス.Clear
項目コンボボックス.Enabled = False
キーワードテキストボックス.Value = ""
キーワードテキストボックス.Enabled = False
実行ボタン.Enabled = False
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
MsgBox "[×]ボタンでは閉じらません"
Cancel = True
End If
End Sub
Private Sub ファイル選択ボタン_Click()
Dim FilePath As String
FilePath = ThisWorkbook.Path & "\"
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = FilePath
.Filters.Clear
.Filters.Add "Excelブック", "*.xlsx"
.Show
If .SelectedItems.Count = 0 Then
パスラベル.Caption = ""
実行ボタン.Enabled = False
シートコンボボックス.Clear
シートコンボボックス.Enabled = False
項目コンボボックス.Enabled = False
キーワードテキストボックス.Enabled = False
Exit Sub
End If
FilePath = .SelectedItems(1)
パスラベル.Caption = FilePath
シートコンボボックス.Enabled = True
Call GetSheet
End With
End Sub
Private Sub シートコンボボックス_Change()
項目コンボボックス.Clear
If シートコンボボックス.Value <> "" Then
項目コンボボックス.Enabled = True
Call GetCol
End If
End Sub
Private Sub 項目コンボボックス_Change()
If 項目コンボボックス.Value <> "" Then
キーワードテキストボックス.Enabled = True
実行ボタン.Enabled = True
End If
End Sub
Sub GetSheet()
Dim i As Long
Dim FileName As String
Dim book As Workbook
Dim MaxSheet As Long
FileName = パスラベル.Caption
If FileName <> "False" Then
Set book = Workbooks.Open(FileName)
End If
book.Application.Visible = False
' 開いたファイルをアクティブにする
book.Activate
MaxSheet = book.Worksheets.Count
For i = 1 To MaxSheet
シートコンボボックス.AddItem book.Worksheets(i).Name
Next i
book.Close
End Sub
Sub GetCol()
Dim j As Long
Dim FileName As String
Dim book As Workbook
Dim sheet As Worksheet
Dim SheetNum As Long
Dim MaxCol As Long
FileName = パスラベル.Caption
If FileName <> "False" Then
Set book = Workbooks.Open(FileName)
End If
book.Application.Visible = False
' 開いたファイルをアクティブにする
book.Activate
SheetNum = シートコンボボックス.ListIndex + 1
Set sheet = book.Worksheets(SheetNum)
MaxCol = sheet.Cells(1, Columns.Count).End(xlToLeft).Column
For j = 1 To MaxCol
項目コンボボックス.AddItem sheet.Cells(1, j).Value
Next j
book.Close
End Sub
Private Sub 実行ボタン_Click()
If 色指定チェックボックス.Value = True Then
Me.Hide
UserForm3.Show vbModeless
Else
Me.Hide
UserForm2.Show vbModeless
Call test
Unload UserForm2
Me.Show
End If
End Sub
Private Sub 終了ボタン_Click()
Unload UserForm1
Application.ScreenUpdating = True
Application.Visible = True
Application.Quit
ThisWorkbook.Close SaveChanges:=False
End Sub
Coloring.bas
Sub sample()
Dim i As Long
Dim j As Long
Dim ColNum As Long
Dim MaxRow As Long
Dim MaxCol As Long
Dim Keyword As String
Dim Target As Variant
Dim Tcnt As Long
Dim Tlen As Long
Dim Search As Range
Dim Pos As Long
Dim FileName As String
Dim book As Workbook
FileName = UserForm1.パスラベル.Caption
If FileName <> "False" Then
Set book = Workbooks.Open(FileName)
End If
book.Application.Visible = False
' 開いたファイルをアクティブにする
book.Activate
Sheets(UserForm1.シートコンボボックス.ListIndex + 1).Select
ColNum = UserForm1.項目コンボボックス.ListIndex + 1
MaxRow = Cells(Rows.Count, ColNum).End(xlUp).Row
MaxCol = Cells(1, Columns.Count).End(xlToLeft).Column
Keyword = UserForm1.キーワードテキストボックス.Value
Target = Split(Keyword, vbCrLf)
Tcnt = UBound(Target)
For i = 0 To Tcnt
Target(i) = Trim(Target(i))
Tlen = Len(Target(i))
Cells(1, MaxCol + i + 1).Value = Target(i)
Select Case i Mod 6
Case 0
Cells(1, MaxCol + i + 1).Font.ColorIndex = 3
Case 1
Cells(1, MaxCol + i + 1).Font.ColorIndex = 5
Case 2
Cells(1, MaxCol + i + 1).Font.ColorIndex = 7
Case 3
Cells(1, MaxCol + i + 1).Font.ColorIndex = 21
Case 4
Cells(1, MaxCol + i + 1).Font.ColorIndex = 28
Case 5
Cells(1, MaxCol + i + 1).Font.ColorIndex = 46
End Select
Cells(1, MaxCol + i + 1).Font.Bold = True
For j = 2 To MaxRow
Set Search = Cells(j, ColNum)
Pos = InStr(Search, Target(i))
If Pos <> 0 Then
Cells(j, MaxCol + i + 1).Value = Target(i)
End If
Do While Pos > 0
Select Case i Mod 6
Case 0
Search.Characters(Pos, Tlen).Font.ColorIndex = 3
Case 1
Search.Characters(Pos, Tlen).Font.ColorIndex = 5
Case 2
Search.Characters(Pos, Tlen).Font.ColorIndex = 7
Case 3
Search.Characters(Pos, Tlen).Font.ColorIndex = 21
Case 4
Search.Characters(Pos, Tlen).Font.ColorIndex = 28
Case 5
Search.Characters(Pos, Tlen).Font.ColorIndex = 46
End Select
Search.Characters(Pos, Tlen).Font.Bold = True
Search.Characters(Pos, Tlen).Font.Italic = True
Pos = InStr(Pos + 1, Search, Target(i))
Loop
Next j
Next i
book.Save
book.Close
End Sub