質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

91.78%

  • VBA

    930questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    798questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

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

解決済

回答 4

投稿 2017/05/08 17:51 ・編集 2017/05/09 19:27

  • 評価
  • クリップ 0
  • VIEW 268

associate

score 1

下記のような感じで、大量のドメインが記載されている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シートのセルを1番上から一つずつ参照し、配列を一つずつ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キーで中断すると、画像のような表示になります。
フィルターというものがよく理解できていないのですが、正常に処理できているのでしょうか?
稚拙な質問で大変申し訳ありません。
何卒よろしくお願い致します。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 4

+2

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

    Application.ScreenUpdating = False
    Application.EnableEvents = False

処理の後に、

    Application.ScreenUpdating = True
    Application.EnableEvents = True

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

追記

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

チューンナップ方針

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

追記の追記

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

チューンナップ方針

  • 2重のループ内で、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で1次元配列に変換して、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


結果、1秒!!で終わりました。

投稿 2017/05/11 10:30

編集 2017/05/14 13:55

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    以下のような回答は評価を下げられます

    • 間違っている回答
    • 質問の回答になっていない投稿
    • 不快な投稿

    評価を下げる際はその理由をコメントに書き込んでください。

  • 2017/05/12 18:38

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

    キャンセル

  • 2017/05/13 00:30

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

    キャンセル

  • 2017/05/14 11:40

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

    キャンセル

checkベストアンサー

+1

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

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

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

投稿 2017/05/08 20:54

編集 2017/05/09 20:48

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    以下のような回答は評価を下げられます

    • 間違っている回答
    • 質問の回答になっていない投稿
    • 不快な投稿

    評価を下げる際はその理由をコメントに書き込んでください。

  • 2017/05/09 19:29

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

    キャンセル

  • 2017/05/09 20:49

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

    キャンセル

  • 2017/05/10 10:22

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

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

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

    キャンセル

+1

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

投稿 2017/05/09 23:35

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    以下のような回答は評価を下げられます

    • 間違っている回答
    • 質問の回答になっていない投稿
    • 不快な投稿

    評価を下げる際はその理由をコメントに書き込んでください。

  • 2017/05/10 10:14

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

    キャンセル

+1

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

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工程のセル範囲取得にループでなくフィルタを利用するのも良いかもしれません。

投稿 2017/05/11 01:41

編集 2017/05/11 02:15

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    以下のような回答は評価を下げられます

    • 間違っている回答
    • 質問の回答になっていない投稿
    • 不快な投稿

    評価を下げる際はその理由をコメントに書き込んでください。

  • 2017/05/12 18:40

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

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

ただいまの回答率

91.78%

関連した質問

同じタグがついた質問を見る

  • VBA

    930questions

    VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

  • Excel

    798questions

    Excelは、マイクロソフト社が開発しているデータ集計や分析を行う表計算ソフトの一つです。文書作成や表計算、資料作成などの多彩な機能を備えており、統合パッケージであるMicrosoft Officeに含まれています。

閲覧数の多いVBAの質問