[[20160217083008]]　『色塗りしたセルのカウント』（MIMI）　ページの最後に飛ぶ

『色塗りしたセルのカウント』（MIMI）

Excel VBA初心者（お恥ずかしながら全く知識がありません）の者です。
仕事で必要に迫られて、インターネットで調べて下記のようなマクロVBAを作成しました。
しかし、作成したものがあまりに重く、Excelを開いてほとんど固まっているような状態でまともに使用ができません。
実用レベルにはどのようにしたらよろしいでしょうか。

【やるべきこと】
複数色にて色塗りしたセルの数を、色別にカウントする。

【作成したもの】
１．色数をカウントする、以下のユーザー定義関数を作成しました。
　※インターネットで検索したものをそのまま貼り付けただけで、意味は理解で
きておりません。

Function ColorCount(R1 As Range, C As Range)

   Dim r As Range

   Application.Volatile
   ColorCount = 0

   For Each r In R1
       If r.Interior.Color = C.Interior.Color Then
           ColorCount = ColorCount + 1
       End If
   Next r

End Function

２．上記のユーザー定義関数を実行する「計算実行」のボタンをマクロで作成しました。
（Ctrl＋Al＋F9を覚えさせただけもの）

３．上記で作成したシートをコピーし、10シート程度作成しました。

１と２を作成したもの1シートだけであれば大変重いものの何とか動くのですが、複数シートのコピーをするとほとんど動かなくなってしまいます。
ただ、仕様上、どうしても複数シートが必要なのです。（減らすにも上記が限界です。）

私は本当にマクロとは何？というレベルの人間で、断片的にインターネットで調べ、それを貼り付けて上記を作成したという状態です。
今から１から理解していくには期限に間に合わず…。
申し訳ありませんが、何か解決策がありましたらご教示いただけますと幸いです。
よろしくお願い致します。

＜使用 Excel：Excel2013、使用 OS：Windows8 ＞

 １つのシートにこの関数を使っているセルがいくつあるのか、また、第1引数で指定する領域サイズがどれぐらいなのか不明ですが、こちら xl2013 で、10シート作成して
 いくつか式をセットして、試してみましたが、そんなに気になるような遅さは体感できません。

 ところで、マクロボタンに登録してあるコードをアップしてもらえませんか？

 >>Ctrl＋Al＋F9を覚えさせただけもの

 この表現が気になっています。

 あと、そのボタンでやりたいことは、アクティブシートのみ再計算ですか？　それともブック内シートすべて再計算ですか？

（β） 2016/02/17(水) 08:58

 もしかして・・・・・

 第1引数として指定してある領域がシート全体のセルになっているのでは？
 もし、そうなら、1048576 * 16384 = 17,179,869,184
 １つの式あたり、170億回　のループ処理ですから、それは、とてつもない処理時間になるでしょうね。

 ですから、このコードの構えではＮＧでしょうね。

 >>今から１から理解していくには期限に間に合わず

 なので、このコードのまま解決したいということなら、それは無理だと思います。
 別の処理方法が必要だと思いますが？

（β） 2016/02/17(水) 09:07

β様、ありがとうございます。
身近にマクロが出来る人間もおらず、困っていたので、お答えいただけることが本当にありがたいです。
申し訳ありませんが、今出先でファイルを見ることが出来ないので、また改めて
ご回答させていただきます。

ご参考までに、取り急ぎ具体的な使用用途をご説明します。
2,500席程度の劇場の座席表を1席1セルになるよう、Excelで作成してあります。
その座席表を1席ずつグループ別（全部で20グループあります）に色分けして
塗っているのですが、そのグループ別の合計数（=各色の合計数）を集計したい
のです。
集計対象として選択しているセルの範囲は、この座席表全体になります。（各座
席の前後に通路として空白のセルを入れるなどしていますので、範囲内の実際
のセル数は倍近くになります。）
複数シートが必要となるのは、日程により色分けが異なるため、日程ごとにシー
ト作成しているからです。
集計は、アクティブシートごと（=日程ごと）に必要です。

上記の用途に叶うのであれば、現在作成している方法以外でも一向に構いません。
（MIMI） 2016/02/17(水) 12:10

 ＞2,500席程度の劇場の座席表

 ですか。。。。ちょっと面白そうですね。

 これは、席のグレードの割振りだけで一件落着になるものなのですか？
 (それらのチケットが、何枚ずつ売れているか、なんて云う集計は後でやったりしないんですか？)

（半平太） 2016/02/17(水) 12:51

 提案です。

 たとえばシートの固定の領域（以下コードでは A1:G1) に　座席タイプによる色を塗っておきます。
 で、各シートにボタンを配置し、そのボタンに、以下の Test1 ないしは Test2 をマクロ登録します。
 座席タイプごとの結果は、固定の領域の、それぞれの色のところに記載します。

 Test1,Test2 いずれも同じことをしていますが、2500セルを相手に処理した場合、
 （当方のＰＣは、かなり性能がいいようなので少し割り引いてみていただくほうがいいかもしれませんが）
 Test1 で、0.15秒前後、Test2 は　0.05秒以下でした。

 Sub Test1()
    Dim myColor As Range
    Dim myMap As Range
    Dim c As Range
    Dim cnt As Variant
    Dim cnm As Variant
    Dim x As Long

    Set myColor = Range("A1:G1")    '★チケット色別管理欄
    Set myMap = Range("A3:AX52")    '★座席領域

    ReDim cnt(1 To myColor.Count)
    cnm = cnt

    For x = 1 To myColor.Count
        cnm(x) = myColor.Cells(x).Interior.Color
    Next

    For Each c In myMap
        For x = 1 To myColor.Count
            If c.Interior.ColorIndex <> xlNone Then
                If cnm(x) = c.Interior.Color Then
                    cnt(x) = cnt(x) + 1
                    Exit For
                End If
            End If
        Next
    Next

    myColor.Value = cnt

 End Sub

 Sub Test2()
    Dim myColor As Range
    Dim myMap As Range
    Dim c As Range
    Dim dic As Object

    Set dic = CreateObject("Scripting.Dictionary")

    Set myColor = Range("A1:G1")    '★チケット色別管理欄
    Set myMap = Range("A3:AX52")    '★座席領域

    For Each c In myColor
        dic(c.Interior.Color) = 0
    Next

    For Each c In myMap
        If dic.exists(c.Interior.Color) Then dic(c.Interior.Color) = dic(c.Interior.Color) + 1
    Next

    myColor.Value = dic.items

 End Sub

（β） 2016/02/17(水) 15:16

 ↑　★のところは、実際のものに直してください。
 座席タイプは、いくつでもＯＫです。

（β） 2016/02/17(水) 15:17

半平太さん>
コメントありがとうございます。
特殊な使用用途ですよね。
割り振りのみに使用しますので、カウントのみで大丈夫です。
これまで目視で数えており、本当に大変だったので何とか使用に叶うものが出来たらと思います。
（MIMI） 2016/02/17(水) 21:30

βさん>
ありがとうございます。
本当に涙が出るほどありがたいです。

今から実際に作成し、改めてご連絡させていただきます。
ちなみに、固定領域の色のところに結果を表示するのではなく、その隣のセルに表示することは出来ますでしょうか。
（MIMI） 2016/02/17(水) 21:36

 アップしたコードは、連続した1行の領域にしてあります。
 もちろん、レイアウトに合わせて、基準の色の場所を見栄えよく配置するのは、少しコードを変えればいけます。
 基準の色をどこに配置したいかを教えていただければ対応します。

 アップした構えのままでも、たとえば、myColor.Value = dic.items　のところを
 myColor.Offset(1).Value = dic.items に変えれば、連続した1行の固定位置の下の行に、それぞれの色の結果を表示することはできます。

（β） 2016/02/17(水) 22:16

β様＞

ご親切に本当にありがとうございます。

実際のレイアウトをご説明させていただきます。

見本用の基準色は、縦1列に配置しており、各色の間には1セルずつ間があいています。
具体的には、下記のそれぞれのセルに各色を塗ってあります。
CI3,CI5,CI7,CI9,CI11,CI13,CI15,CI17,CI19,CI21,CI23,CI25,CI27,CI29,CI31,CI33,CI35,CI37,CI39,CI41

カウントしたい座席の領域は、A1:CH91です。

できれば、それぞれの色の結果は上記基準の場所の右隣である
CJ3,CJ5,CJ7,CJ9,CJ11,CJ13,CJ15,CJ17,CJ19,CJ21,CJ23,CJ25,CJ27,CJ29,CJ31,CJ33,CJ35,CJ37,CJ39,CJ41
にそれぞれ表示できればと考えております。
（MIMI） 2016/02/17(水) 23:35

こんにちは。

条件付書式とcountif関数で行けそうです。
たとえば、セルに１と入れたら赤色が付くようにしておいて（色見本のセルも同様に）
countif関数で、座席範囲内の１の数を調べます。

（　佳　） 2016/02/18(木) 07:02

佳様>
ご回答ありがとうございます。
色塗りをするセルには、全て元々数字が入っています。(座席番号が入っています)
ですので、条件式書式などで新たに数字を入れ、それをカウントするような方法はどうしても難しいように思います。
（MIMI） 2016/02/18(木) 07:34

 Test2をベースに改訂してみました。さすがに、7826セル領域ですので、当方の環境で 0.15秒　かかりました。

 Sub Test3()

    Dim myColor As Range
    Dim myMap As Range
    Dim c As Range
    Dim dic As Object
    Dim pos As Object
    Dim k As Variant

    Set dic = CreateObject("Scripting.Dictionary")
    Set pos = CreateObject("Scripting.Dictionary")

    Set myColor = Range("CI3,CI5,CI7,CI9,CI11,CI13,CI15,CI17,CI19,CI21,CI23,CI25,CI27,CI29,CI31,CI33,CI35,CI37,CI39,CI41")    '★チケット色別管理欄
    Set myMap = Range("A1:CH91")    '★座席領域

    For Each c In myColor
        dic(c.Interior.Color) = 0
        Set pos(c.Interior.Color) = c
    Next

    For Each c In myMap
        If dic.exists(c.Interior.Color) Then dic(c.Interior.Color) = dic(c.Interior.Color) + 1
    Next

    For Each k In dic
        pos(k).Offset(, 1).Value = dic(k)
    Next

 End Sub

（β） 2016/02/18(木) 07:45

β様>
ご丁寧に本当にありがとうございます。
試してみたところ、無事にカウントすることが出来ました。
スピードも恐らく1秒程度で、全く問題ないどころか、驚くほど速かったです。

β様の最初のご指摘で、マクロの実行範囲をブック全てにしていることに気付き
ました。
また、領域のセル数が多くなるほど作業が遅くなることを知り、本日領域を出来
る限り絞り込みました。

これほど無知なレベルで、周りに分かる人間もおらず、路頭に迷っていたので、
本当に涙が出るほど嬉しいです。
迅速に、そしてとても丁寧にお答え下さったβ様には心から感謝申し上げます。
直接お会いしてお礼を申し上げたいほどです。

β様、そして書き込みして下さった半平太様、佳様、本当にありがとうございました。
（MIMI） 2016/02/18(木) 12:15

こんにちは。解決後ですが。

＞色塗りをするセルには、全て元々数字が入っています。(座席番号が入っています)
＞ですので、条件式書式などで新たに数字を入れ、それをカウントするような方法はどうしても難しいように思います。

条件付書式では、通路に１と入れて座席を赤くすることもできます。
もしまだ見ておられればご参考に。
（　佳　） 2016/02/19(金) 22:27

コメント返信：

[ 一覧(最新更新順) ]

[[20160217083008]] 『色塗りしたセルのカウント』（MIMI） ページの最後に飛ぶ

[[20160217083008]]　『色塗りしたセルのカウント』（MIMI）　ページの最後に飛ぶ