Created
December 6, 2019 02:40
-
-
Save KentaGoto/f24d7f4f8e840404b2b1eeeddcfd4e7f to your computer and use it in GitHub Desktop.
VBA
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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