Skip to content

Instantly share code, notes, and snippets.

@KentaGoto
Created December 6, 2019 02:40
Show Gist options
  • Save KentaGoto/f24d7f4f8e840404b2b1eeeddcfd4e7f to your computer and use it in GitHub Desktop.
Save KentaGoto/f24d7f4f8e840404b2b1eeeddcfd4e7f to your computer and use it in GitHub Desktop.
VBA
Option Explicit
Sub ExtractHighlightChars()
' 特定の色のついた文字を抽出する
Application.ScreenUpdating = False
Dim Start, Finish As Variant
Start = Time
Dim jikan As String
jikan = Format(Now, "yyyymmddhhmmss")
'Debug.Print (jikan)
' チェック対象の文字色
Dim CHECK_COLOR As Long
CHECK_COLOR = Range("D3").Value
' 入力ファイル
Dim inputFile As Variant
inputFile = Application.GetOpenFilename("ファイル(*.xlsx),*.xlsx")
If VarType(inputFile) = vbBoolean Then
End
End If
' 対象文字色に一致した文字の配列
Dim extractedChars() As String
Dim charsCount As Long
charsCount = 0
' ファイルオープン
Dim inputBook As Workbook
Set inputBook = Workbooks.Open(inputFile, ReadOnly:=True)
' ログ・ファイル
Dim datFile As String
datFile = ActiveWorkbook.Path & "\" & jikan & "_data.txt"
' ログファイルオープン
Open datFile For Output As #1
Dim cellCount As Long
Dim line As Long
' シート数分繰り返し
Dim i As Long
For i = 1 To inputBook.Worksheets.count
' 列の分繰り返し
Dim j As Long
For j = 1 To Columns.count
'For j = 1 To 1000 ' 1000列目まで
'Debug.Print ("列数: " & line)
' 行の最大値(1048576)は大きいので、各列の最後のセルまでを繰り返し
Dim k As Long
For k = 1 To inputBook.Worksheets(i).Cells(Rows.count, j).End(xlUp).Row
'Debug.Print ("行数: " & cellCount)
' 処理対象ファイルのステータスバーに進捗を表示
Application.StatusBar = "Processing..." & String(Int(cellCount / 1000), "■")
DoEvents
' チェック中のフラグ
Dim isMatch As Boolean
isMatch = False
' 文字数分繰り返し
Dim l As Long
For l = 1 To Len(inputBook.Worksheets(i).Cells(k, j))
' チェック対象の文字色に一致するかどうか
If inputBook.Worksheets(i).Cells(k, j).Characters(Start:=l, Length:=1).Font.ColorIndex = CHECK_COLOR Then
' まだチェック中でなければ配列の要素数を増やす
If isMatch = False Then
charsCount = charsCount + 1
ReDim Preserve extractedChars(charsCount - 1)
isMatch = True
End If
extractedChars(charsCount - 1) = extractedChars(charsCount - 1) + Mid(inputBook.Worksheets(i).Cells(k, j).Text, l, 1)
Else
isMatch = False
End If
Next l
cellCount = cellCount + 1
Next k
Next j
Next i
' 出力
Dim p As Long
For p = 0 To UBound(extractedChars)
' Debug.Print (extractedChars(p)) ' イミディエイトウィンドウは200行までしか出ない
Print #1, extractedChars(p)
Next p
' ファイルクローズ
inputBook.Close SaveChanges:=False
Set inputBook = Nothing
' ログファイルクローズ
Close #1
Finish = Time
Application.StatusBar = False
MsgBox "処理が完了しました。" & vbLf & "実行時間: " & Format(Finish - Start, "nn分ss秒"), vbOKOnly, "完了"
' テキストエディタでログを開く
With CreateObject("Wscript.Shell")
.Run datFile, 5
End With
Application.ScreenUpdating = True
End Sub
Sub Run()
Module1.ColorIndexCheck
Module1.ExtractHighlightChars
End Sub
Sub ColorIndexCheck()
If Range("D3") <> "" Then
If IsNumeric(Range("D3")) = True Then
Else
MsgBox "ColorIndexを入力してください。", vbOKOnly + vbCritical, "ERROR"
End
End If
Else
MsgBox "空欄です。" & vbLf & "ColorIndexを入力してください。", vbOKOnly + vbCritical, "ERROR"
End
End If
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment