【VBA】ドメインのリスト一覧から配列に含まれるドメインのみを着色したい

Question

下記のような感じで、大量のドメインが記載されているExcelシートから、特定のドメインのみを着色するマクロを書きたいです。

Excelシートの例

	A	B	C
1	ドメイン	日付
2	example.com	2017/05/08
3	example.jp	2017/05/07
4	etc.example.jp	2017/05/07
5	example.ne	2017/05/06
︙	︙	︙	︙

テキストファイルの例

example.jp
teratail.com
test.xyz
example.ne

（上記の場合なら重複しているexample.jpとexample.neを着色したい）

上記のExcelシートとは別に、ドメインを一行ずつリストアップしたテキストファイルを用意し、そこに載っているドメインのセルの背景色を赤色に着色したいです。
量が非常に多く、数万件あるのでなるべく負荷のかからないようにコーディングする必要があります。

下記の私が考えた方法はあまりにも時間がかかりすぎたり、負荷が高すぎてExcel自体が応答しなくなりダメでした。
よろしければ知恵をお貸しください。

######（案）テキストファイルを一行ずつ読み込み、配列に代入し、Excelシートのセルを１番上から一つずつ参照し、配列を一つずつlike演算子で検証する

OpenFileName = Application.GetOpenFilename("テキスト文書,*.txt")
        If OpenFileName <> "False" Then
            Workbooks.Open OpenFileName
        Else
            GoTo hoge
        End If
        
        'リストの読み込み
        Open OpenFileName For Input As #1
        Workbooks(1).Activate
            Do Until EOF(1)
                ReDim Preserve ng_domain(a)
                Line Input #1, buf
                ng_domain(a) = buf
                i = 2
                    Do While Cells(i, 1) <> ""
                        If Cells(i, 1).Value Like "*" + ng_domain(n) + "*" Then
                            Cells(i, 1).Interior.Color = RGB(242, 221, 220)
                        Else
                        End If
                    i = i + 1
                    Loop
                a = a + 1
            Loop
        Close #1

もしくは

Do While Cells(i, 1) <> ""
    For n = n To a
      If Cells(i, 1).Value Like "*" & ng_domain(n) & "*" Then
             Cells(i, 1).Interior.Color = RGB(242, 221, 220)
           Else
           
           End If
        Next n        
      n = 0
        i = i + 1
Loop

何か良い案はありませんでしょうか…。
よろしくお願い致します。

---

（2017/05/05 追記）
Nuu様
迅速なご回答ありがとうございます。
ご提案頂いたコードを下記のように実行しました。

Sub テスト()

    q1 = MsgBox("実行", 0, "")
    If q1 = vbCancel Then
        MsgBox "キャンセル", 0, ""
        GoTo endmark
    Else
    End If
    
    Close #1
    openfilename = Application.GetOpenFilename("テキスト文書,*.txt")
    Open openfilename For Input As #1
    
        Do Until EOF(1)
            Line Input #1, buf
            With Workbooks(1).Worksheets(1).Columns(1)
                .AutoFilter Field:=1, Criteria1:="*" & buf & "*"
                .CurrentRegion.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(242, 221, 220)
                .AutoFilter
                a = a + 1
                Application.StatusBar = a & "件目"
            End With
        Loop
    Workbooks(1).Worksheets(1).Rows(1).Interior.Color = xlNone

endmark:
End Sub

（コード全てです）

上記コードで実行したところ、非常に時間がかかっているのでまだコードが完了するまで実行できていないのですが、
Escキーで中断すると、画像のような表示になります。
フィルターというものがよく理解できていないのですが、正常に処理できているのでしょうか？
稚拙な質問で大変申し訳ありません。
何卒よろしくお願い致します。

Answer 1

追記されたコードの
処理の前に、

    Application.ScreenUpdating = False
    Application.EnableEvents = False

処理の後に、

    Application.ScreenUpdating = True
    Application.EnableEvents = True

を挿入すると速度はかなり改善されると思います。

追記

さらなる高速化してみました。

チューンナップ方針

• テキストファイルはFileSystemObjectで全文を読み込む（Line Input で１行ずつ読み込むより高速）、Splitで行毎の配列にする
• セルに一つずつアクセスせずに、検索対象セルを一気に配列に代入して、配列にアクセスする。
• 上記２つの配列をFor Eachでループさせて、条件チェックして、該当するドメインを動的配列に格納。
• AutoFilter の Criteria1 に上記の動的配列を設定して、実行する（１回の処理で済む）

Sub SetColor()
    Dim OpenFileName As String
    Dim buf As String
    Dim aryNgDomain
    Dim aryADomain()
    Dim aryRDomain()
    Dim NgDomain, ADomain
    Dim n As Long

    Sheet1.Cells.Interior.Color = xlNone '背景色リセット
    OpenFileName = Application.GetOpenFilename("テキスト文書,*.txt")

    Dim t As Single
    t = Timer

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    'テキストを一気に配列に読み込む
    With CreateObject("Scripting.FileSystemObject")
        With .GetFile(OpenFileName).OpenAsTextStream
            buf = .ReadAll
            .Close
        End With
    End With
    aryNgDomain = Split(buf, vbCrLf)

    'NGドメインに一致するドメインを配列に格納
    With Workbooks(1).Worksheets(1)
        aryADomain = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
        For Each NgDomain In aryNgDomain
            For Each ADomain In aryADomain
                If ADomain Like "*" & NgDomain & "*" Then
                    ReDim Preserve aryRDomain(n)
                    aryRDomain(n) = ADomain
                    n = n + 1
                End If
            Next
        Next
    End With

    '該当ドメインの背景色設定
    With Workbooks(1).Worksheets(1).Range("A1")
        .AutoFilter Field:=1, Criteria1:=aryRDomain, Operator:=xlFilterValues
        .CurrentRegion.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(242, 221, 220)
        .AutoFilter
    End With
    Workbooks(1).Worksheets(1).Rows(1).Interior.Color = xlNone
    Application.EnableEvents = True
    Application.ScreenUpdating = True

    t = Timer - t
    Debug.Print "setColor "; t & "秒かかりました。"

End Sub

ドメインリスト 20,000件、テキストのNGドメイン 3,000件のサンプルデータを rnd関数で自動生成しました。
それを元に実験してみました。
当方の環境(Win10 64bit, Excel2016 32bit, CPU Core i7, RAM 16GB)

質問の追記のコードに Application.EnableEvents = False Application.ScreenUpdating = True を追加したもので、53秒前後、上記のコードで、18秒前後でした。

追記の追記

さらにさらにチューンナップしてみました。

チューンナップ方針

• ２重のループ内で、Like演算子で部分一致チェックをしているが、これに時間がかかっているようだ。そこで、 ADomain Like "*" & NgDomain & "*" を InStr(ADomain , NgDomain ) > 0 変更してみたら、処理時間が半分に短縮できた。
• InStrって高速なんだな！ならば、検索対象ドメインを連結して一つの文字列として、InStrで検索したらどうだろう。

Sub SetColor4()
    Dim OpenFileName As String
    Dim Buf As String
    Dim aryNgDomain
    Dim aryADomain()
    Dim strADomain As String
    Dim aryRDomain()
    Dim NgDomain, ADomain
    Dim n As Long, p As Long, p0 As Long

    Sheet1.Cells.Interior.Color = xlNone    '背景色リセット
    OpenFileName = Application.GetOpenFilename("テキスト文書,*.txt")

    Dim t As Single
    t = Timer

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    'テキストを一気に配列に読み込む
    With CreateObject("Scripting.FileSystemObject")
        With .GetFile(OpenFileName).OpenAsTextStream
            Buf = .ReadAll
            .Close
        End With
    End With
    aryNgDomain = Split(Buf, vbCrLf)

    With Workbooks(1).Worksheets(1)
        aryADomain = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With
    'Transposeで１次元配列に変換して、Joinで結合
    strADomain = "|" & Join(WorksheetFunction.Transpose(aryADomain), "|") & "|"

    'NGドメインに一致するドメインを配列に格納
    For Each NgDomain In aryNgDomain
        p = 1
        Do
            p = InStr(p, strADomain, NgDomain, vbBinaryCompare)
            If p = 0 Then Exit Do
            p0 = InStrRev(strADomain, "|", p, vbBinaryCompare) + 1
            ReDim Preserve aryRDomain(n)
            p = InStr(p, strADomain, "|")
            aryRDomain(n) = Mid(strADomain, p0, p - p0)
            n = n + 1
        Loop
    Next

    '該当ドメインの背景色設定
    With Workbooks(1).Worksheets(1).Range("A1")
        .AutoFilter Field:=1, Criteria1:=aryRDomain, Operator:=xlFilterValues
        .CurrentRegion.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(242, 221, 220)
        .AutoFilter
    End With
    Workbooks(1).Worksheets(1).Rows(1).Interior.Color = xlNone
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    t = Timer - t
    Debug.Print "setColor2 "; t & "秒かかりました。"
End Sub

結果、１秒！！で終わりました。

Comments

[associate]

ありがとうございます。
実際にコードに組み込んで運用しております。
非常に参考になります。

[hatena19]

さらなるチューンナップコードを追記します。

[N-u-u]

AutoFilterの条件に配列も指定できるのですね。
勉強になりました。

Answer 2

解決済みとなっていおりましたがお返事をいただきましたので自分なりの方法を置いていきます。
一つにまとめて書いたのでコード見づらいですが･･･
配列を使用と工程分割で最終的な照合ループ回数と塗りつぶし回数を軽減で考えております。
同条件のテストデータが用意できなかったため正確な速度検証は出来ておりません。
逆に現状より速度が落ちてしまったらすみません。
少しでも参考になれば幸いです。

Public Sub TeraTest()
            
    Dim fileName As String
    fileName = Application.GetOpenFilename("テキスト文書,*.txt")
  
    If fileName = "False" Then Exit Sub
    
    Dim startTime As Variant
    Dim endTime As Variant
    startTime = Time
    
    Dim ws As Worksheet
    Dim endRow As Long
    Dim targetRange As Range
  
    Set ws = Workbooks(1).Worksheets(1)
    endRow = ws.Cells(Rows.Count, 1).End(xlUp).Row 'ドメイン列の最終行取得
  
    ws.Activate
    Set targetRange = ws.Range(Cells(1, 1), Cells(endRow, 1))  'ドメイン列の照合範囲を取得
    
    '第1工程
    'テキスト文書内のドメインの内､実際にExcelシートに存在するものを選別
    
    Dim txt As String
    Dim txtCount As Long
    Dim hasFound As Boolean
    Dim domainNumbers() As Long
    Dim domains() As String
    Dim n As Long
    
    hasFound = False
    n = 0
    
    Open fileName For Input As #1
        Do Until EOF(1)
            Line Input #1, txt
            
            txtCount = WorksheetFunction.CountIf(targetRange, "*" & txt & "*")  'CountIF関数で範囲内の一致セル数を取得
                
            If txtCount > 0 Then                '一致セル数が1以上なら
                hasFound = True
                ReDim Preserve domainNumbers(n)
                ReDim Preserve domains(n)
                domainNumbers(n) = txtCount         '一致セル数を配列に追加
                domains(n) = txt               '一致したドメインを配列に追加
                n = n + 1
            End If
        Loop
    Close #1
    
    If hasFound = False Then
        MsgBox "テキストファイル内に一致するドメインはありません"
        Exit Sub
    End If
    
    '第2工程
    '選別したドメイン数分ループして一致セルを取得
    
    Dim i As Long
    Dim j As Long
    Dim matchedRange As Range
    Dim matchedNumber As Long
    
    For i = LBound(domains) To UBound(domains)
        matchedNumber = 0  'ループ内の一致セル数初期化
          
        For j = 1 To endRow
            If ws.Cells(j, 1).Value Like "*" & domains(i) & "*" Then
                If matchedRange Is Nothing Then
                    Set matchedRange = ws.Cells(j, 1)  '初回時は塗りつぶし範囲に設定
                Else
                    Set matchedRange = Union(matchedRange, ws.Cells(j, 1))  '2セル目以降はUnionで塗りつぶし範囲に追加
                End If
                matchedNumber = matchedNumber + 1
                If matchedNumber = domainNumbers(i) Then Exit For  'ループ内で取得した一致セル数が第1工程で取得したセル数と一致した時点でループ抜け
            End If
        Next j
    Next i
  
    matchedRange.Interior.Color = RGB(242, 221, 220)  '取得した範囲を一括塗りつぶし
       
    endTime = Time - startTime
    
    MsgBox UBound(domains) + 1 & "個のドメインが一致しました" & vbCrLf & _
            matchedRange.Count & "個のセルを塗りつぶしました" & vbCrLf & _
            "所要時間：" & Second(endTime) & "秒"
  
End Sub

試していませんが第2工程のセル範囲取得にループでなくフィルタを利用するのも良いかもしれません。

Comments

[associate]

わざわざコードを一通り考えてくださりありがとうございます。
本件は解決済みのため、提案してくださった手段は試していませんが、今後のコーディングの参考にしていきたいと思います。
今後とも何卒よろしくお願い申し上げます。

Answer 3

ExcelVBAはセルに値を入れたり、色付けしたりとセルへの処理頻度が多いほど速度が落ちますので今回の場合、如何に着色する回数を減らすかがポイントになるかと思います。
また、テキストファイル内のドメイン数だけループするので少なからず速度へ影響があるはずですが、実際はどの位あるのでしょうか？

Comments

[associate]

ご回答ありがとうございます。
具体的なドメインの数ですが、検索されるドメインの件数（＝Excelシート内の件数）は約20,000件で、検索するドメインの件数（＝テキストファイル内の件数）は約3,000件です。
20,000件のドメインリストを、3,000種類のドメインと照合し、一致するものがあれば着色するという流れになります。
尚、ドメインの件数はどちらも今後増える可能性があります。

Answer 4

オートフィルタを活用してみましょう。
ループを回さずに条件に一致するデータを一括で取得できます。
下記のコードは一部修正が必要になると思いますが、シートがシンプルな作りであれば簡単に修正できると思います。

    Do Until EOF(1)
        Line Input #1, buf
        With Workbooks(1).Worksheets(1).Columns(1)
            'A列から変数bufの値を含む行を抽出
            .AutoFilter Field:=1, Criteria1:="*" & buf & "*"
            '抽出した行の背景色を赤にする(行単位で着色されるので要改善)
            .CurrentRegion.SpecialCells(xlCellTypeVisible).Interior.Color = RGB(242, 221, 220)
            'オートフィルタ解除
            .AutoFilter
        End With
    Loop
    
    'ヘッダ行の背景色を戻す
    Workbooks(1).Worksheets(1).Rows(1).Interior.Color = xlNone

※ブック名、シート名は適宜変更して下さい。

---

（2017/05/09 追記）

まずは下記の画像を参考にして手作業でオートフィルタを実行してみて下さい。

フィルタに時間がかかる場合、PCスペック的な問題かと思われます。
別のロジックを考えましょう。（セルを二次元配列に変換して比較する等...）
すぐにフィルタリングできる・そもそもデータがヒットしない等の場合、プログラムに何らかの問題があります。

ひとまず手作業でフィルターを実行し、フィルタを使ったロジックが有用かを判定しましょう。

Comments

[associate]

ご回答ありがとうございます。
質問内容に追記いたしましたので、宜しければご確認の程よろしくお願い致します。

[N-u-u]

回答追記しました。ご確認下さい。

[associate]

確認致しました。ご回答ありがとうございます。

フィルタ機能の使い勝手を理解することが出来ました。
試しに、20,000件のドメインリストから「*example.com*」を検索したところ、一秒もかからずに処理することができました。
どうやら、検索するドメイン数が多すぎるのが問題のようです。（約3000件）

少しコードを書き換えて実行したところ、時間はかかりますが意図した通りの動きをしました。
大変勉強になりました。ありがとうございました。