条件付き書式で行うと重くて遅いのです

投稿者 : ぷんぷん     投稿日時 : 2022/11/08(Tue) 16:03:54     OS : Windows 10     EXCEL : Excel 2019

---

宜しくお願いします。

データー件数が1シートに25000件くらいあるシート（件数は毎週変わる20000件から30000件程度）

シート名は毎週変わる

・シート07（今週のシート　25000件程度）

・シート03（先週のシート　23000件程度）

データーは減るものもあるし増えるものもあります。
重複していないデータのセルに色を付けたいです。

シート07のM列とシート03のM列を比べて、重複していない
セルをシート07に色を付けたい（M列には5桁ほどの注番が入っています）

条件付き書式で数式を使用して（Counifを使い）作ってみましたが重いのです。
そして、シート名が毎週変わるのがネックになり困っています。
何か良いExcel　VBAはありますでしょうか

初心者の質問で申し訳ございませんがご指南お願いいたします。

投稿者 : さんこう     投稿日時 : 2022/11/08(Tue) 16:20:54

---

＞条件付き書式で数式を使用して（Counifを使い）作ってみましたが重いのです。

30000件程度なら、たいしたことないと思いますが。
仮にVBAで作るにしても、CountIfを使うことになるでしょう。


＞シート名が毎週変わるのがネックになり困っています。
＞何か良いExcel　VBAはありますでしょうか

条件付き書式の設定を「マクロの記録」で記録したものを手直しすればよろしいかと思います。

投稿者 : tek     投稿日時 : 2022/11/09(Wed) 00:46:17

---

一例です。たぶん1秒くらいかかります。

Sub test()
    Const UN = 200
    Dim r As Range, r1() As Range
    Dim 今週のシート As Worksheet, 先週のシート As Worksheet
    Dim dic As Object
    Dim n As Long, nn As Long, x As Long, y As Long
    
    On Error Resume Next
    Set r = Application.InputBox("今週のシートを指定ください", "セル選択", Type:=8)
    If r Is Nothing Then Exit Sub
    Set 今週のシート = r.Worksheet
    Set r = Nothing
    Set r = Application.InputBox("先週のシートを指定ください", "セル選択", Type:=8)
    If r Is Nothing Then Exit Sub
    On Error GoTo 0
    Set 先週のシート = r.Worksheet
    Set dic = CreateObject("Scripting.Dictionary")
    For Each r In 先週のシート.Columns("m:m").SpecialCells(xlCellTypeConstants)
        dic(r.Value) = Empty
    Next
    n = 今週のシート.Columns("m:m").SpecialCells(xlCellTypeConstants).Cells.Count
    nn = Int(Sqr(n / UN))
    ReDim r1(0 To nn, 0 To nn)
    For Each r In 今週のシート.Columns("m:m").SpecialCells(xlCellTypeConstants)
        If Not dic.exists(r.Value) Then
            If r1(x, y) Is Nothing Then
                Set r1(x, y) = r
            Else
                Set r1(x, y) = Union(r1(x, y), r)
            End If
            If UN < r1(x, y).Areas.Count Then
                x = x + 1
                If nn < x Then
                    x = 0
                    y = y + 1
                End If
            End If
        End If
    Next
    For x = 0 To UBound(r1)     'x,0に集める
        For y = 1 To UBound(r1, 2)
            If Not r1(x, y) Is Nothing Then Set r1(x, 0) = Union(r1(x, 0), r1(x, y))
        Next
    Next
    For x = 1 To UBound(r1)     '0,0に集める
        If Not r1(x, 0) Is Nothing Then Set r1(0, 0) = Union(r1(0, 0), r1(x, 0))
    Next
    r1(0, 0).Interior.Color = vbRed '色を塗る
End Sub

投稿者 : ぷんぷん     投稿日時 : 2022/11/09(Wed) 10:23:36

---

■[返信 1] さんこうさん（2022-11-08 16:20:54）の記事
＞ ＞条件付き書式で数式を使用して（Counifを使い）作ってみましたが重いのです。
＞
＞ 30000件程度なら、たいしたことないと思いますが。
＞ 仮にVBAで作るにしても、CountIfを使うことになるでしょう。
＞
＞
＞ ＞シート名が毎週変わるのがネックになり困っています。
＞ ＞何か良いExcel　VBAはありますでしょうか
＞
＞ 条件付き書式の設定を「マクロの記録」で記録したものを手直しすればよろしいかと思います。
＞

さんこうさん　ありがとうございます。

マクロの記録で作ってみましたが、毎週シート名が変わるため
countifの参照するシート名を任意にしたいのですが上手く行かず困ってます。

"=COUNTIF('イチゴの出荷1105'!M:M,M3)=0"

　　　　　　　　　↑　ここのシート名が毎週変わるので、
shuut(2)とかsheetsNext(右側指定）を使いたいのですが上手く行かず
それ以外は動くのですが・・・

投稿者 : ぷんぷん     投稿日時 : 2022/11/09(Wed) 10:30:14

---

■[返信 2] tekさん（2022-11-09 00:46:17）の記事
＞ 一例です。たぶん1秒くらいかかります。
＞
＞ Sub test()
＞ Const UN = 200
＞ Dim r As Range, r1() As Range
＞ Dim 今週のシート As Worksheet, 先週のシート As Worksheet
＞ Dim dic As Object
＞ Dim n As Long, nn As Long, x As Long, y As Long
＞
＞ On Error Resume Next
＞ Set r = Application.InputBox("今週のシートを指定ください", "セル選択", Type:=8)
＞ If r Is Nothing Then Exit Sub
＞ Set 今週のシート = r.Worksheet
＞ Set r = Nothing
＞ Set r = Application.InputBox("先週のシートを指定ください", "セル選択", Type:=8)
＞ If r Is Nothing Then Exit Sub
＞ On Error GoTo 0
＞ Set 先週のシート = r.Worksheet
＞ Set dic = CreateObject("Scripting.Dictionary")
＞ For Each r In 先週のシート.Columns("m:m").SpecialCells(xlCellTypeConstants)
＞ dic(r.Value) = Empty
＞ Next
＞ n = 今週のシート.Columns("m:m").SpecialCells(xlCellTypeConstants).Cells.Count
＞ nn = Int(Sqr(n / UN))
＞ ReDim r1(0 To nn, 0 To nn)
＞ For Each r In 今週のシート.Columns("m:m").SpecialCells(xlCellTypeConstants)
＞ If Not dic.exists(r.Value) Then
＞ If r1(x, y) Is Nothing Then
＞ Set r1(x, y) = r
＞ Else
＞ Set r1(x, y) = Union(r1(x, y), r)
＞ End If
＞ If UN < r1(x, y).Areas.Count Then
＞ x = x + 1
＞ If nn < x Then
＞ x = 0
＞ y = y + 1
＞ End If
＞ End If
＞ End If
＞ Next
＞ For x = 0 To UBound(r1) 'x,0に集める
＞ For y = 1 To UBound(r1, 2)
＞ If Not r1(x, y) Is Nothing Then Set r1(x, 0) = Union(r1(x, 0), r1(x, y))
＞ Next
＞ Next
＞ For x = 1 To UBound(r1) '0,0に集める
＞ If Not r1(x, 0) Is Nothing Then Set r1(0, 0) = Union(r1(0, 0), r1(x, 0))
＞ Next
＞ r1(0, 0).Interior.Color = vbRed '色を塗る
＞ End Sub
＞
＞

tekさん　ありがとうございます。

こちらのコードもお借りして試してみますね。
検索自体は1分ほどでもいいのですが、その後にフィルター検索を
行うときにすごく重くなるのです。
しかしすごいコードですね。
1行ずつ解読して勉強させていただきます。

投稿者 : さんこう     投稿日時 : 2022/11/09(Wed) 11:00:47

---

＞countifの参照するシート名を任意にしたいのですが上手く行かず困ってます。

こんな感じでしょうか。

Sub a()
    MsgBox "=COUNTIF('" & ActiveSheet.Next.Name & "'!M:M,M3)=0"
End Sub

投稿者 : ぷんぷん     投稿日時 : 2022/11/09(Wed) 18:19:52

---

■[返信 5] さんこうさん（2022-11-09 11:00:47）の記事
＞ ＞countifの参照するシート名を任意にしたいのですが上手く行かず困ってます。
＞
＞ こんな感じでしょうか。
＞
＞
＞ Sub a()
＞ MsgBox "=COUNTIF('" & ActiveSheet.Next.Name & "'!M:M,M3)=0"
＞ End Sub
＞


さんこうさん　再度のご指南ありがとうございました。
感動です!!動きました。
すごく勉強になりました。
自分は、もっと学ばないとだめですね。
また、困ったことがありましたら質問させていただきます。