[[20170804215608]]　『複数条件のカウントを転帰　日付が変わると転帰場』（まさこ）　ページの最後に飛ぶ

『複数条件のカウントを転帰　日付が変わると転帰場所も変わる』（まさこ）

ブックA.xlsmの1シート（シートは月の枚数分あります：2017年9月であれば30個のシート　シートの名前は1-30の数字）

C2に2017年9月1日のように日付
C3に木のように曜日を入力しています
シートの名前は1です。
氏名の右となりのセルには　あ～こ　までの１０パターン程度の文字が入力されます。　以下の表では　あ　い　の２パターンですが。

  C　    F     G  　  　H 　　I    　　J 　　K  　　  L M  　　  N　　O　　　　　　P　　Q　　R　S　　　　　
1     
2 9月1日
3　木
4　　　大阪太郎　あ　　滋賀花子　あ　　　　　　　　大阪太郎　あ　　滋賀花子　あ　　三重太郎　い　　
5　　　大阪太郎　あ　　滋賀花子　あ　三重太郎　い
6  　　大阪太郎　あ
7
8　　　　　　　　　　　大阪太郎　あ

ブックAの2シート

  C　    F     G  　  　H 　　I    　　J 　　K  　　  L M  　　  N　　O　　　　　　P　　Q　　R　S　
1     
2     9月2日
3　　　金
4　　　　　滋賀花子　あ
5　　　　　　　　　　　　大阪太郎　あ　大阪太郎　あ

ブックB.xlsmのあシート　　（あ～こ　まで１０パターン程度のシートが同様のレイアウトであります。）

　A　　B　　C　　D　　　・・・　　X　Y　Z　AA　　AB　AC　AD　AE　　AF　AG　AH　AI　　　　・・・　
1　　
2
3
4　　　　　　　　　　　　　　　　　9月1日　　　　　9月2日　　　　　9月3日
5　　　　　　　　　　　　　　　　　　木　　　　　　　金　　　　　　　土
6　　　　　氏名　　　　　・・・　　○▲×　合計　　　　　
7　　　　大阪太郎　　　　　　　　　4 1 0 　←表示させたい
8　　　　滋賀花子　　　　　　　　　2 1 0　 ←表示させたい
9　　　　三重太郎　　　　　　　　　0 0 0 ←表示させたい
　　

ブックB.xlsmのいシート

　A　　B　　C　　D　　　・・・　　X　Y　Z　AA　　AB　AC　AD　AE　　AF　AG　AH　AI　　　　・・・　
1　　
2
3
4　　　　　　　　　　　　　　　　　9月1日　　　　　9月2日　　　　　9月3日
5　　　　　　　　　　　　　　　　　　木　　　　　　　金　　　　　　　土
6　　　　　氏名　　　　　・・・　　○▲×　合計　　　　　
7　　　　兵庫太郎　　　　　　　　　0 0 0 　←表示させたい
8　　　　和歌山花子　　　　　　　　0 0 0　 ←表示させたい
9　　　　三重太郎　　　　　　　　　1 0 1 ←表示させたい

ブックBの各シートのC7からC列に氏名が入力されていきます。

☆マクロで出来たらうれしいこと☆
1,ブックB.xlsmのあシートのC7の名前と完全一致する文字列の右隣のセルがあ　をブックA.xlsmのF4：K8の範囲でカウントし、ブックBのあシートのX7に表示。
　　　　　　同上　　　　　C8 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　X8　　　。
　　　　　　同上　　　　　C9 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　X9　　　。
2,ブックB.xlsmのあシートのC7の名前と完全一致する文字列の右隣のセルがあ　をブックA.xlsmのL4：O8の範囲でカウントし、ブックBのあシートのY7に表示。
　　　　　　同上　　　　　C8 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Y8　　　。
　　　　　　同上　　　　　C9 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Y9　　　。　　
3,ブックB.xlsmのあシートのC7の名前と完全一致する文字列の右隣のセルがあ　をブックA.xlsmのP4 : S8の範囲でカウントし、ブックBのあシートのZ7に表示。
　　　　　　同上　　　　　C8 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Z8　　　。
　　　　　　同上　　　　　C9 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Z9　　　　。

4．ブックB.xlsmのいシートのC7の名前と完全一致する文字列の右隣のセルがい　をブックA.xlsmのF4：K8の範囲でカウントし、ブックBのあシートのX7に表示。
　　　　　　同上　　　　　C8 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　X8　　　。
　　　　　　同上　　　　　C9 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　X9　　　。
5,ブックB.xlsmのいシートのC7の名前と完全一致する文字列の右隣のセルがい　をブックA.xlsmのL4：O8の範囲でカウントし、ブックBのあシートのY7に表示。
　　　　　　同上　　　　　C8 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Y8　　　。
　　　　　　同上　　　　　C9 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Y9　　　。　　
6,ブックB.xlsmのいシートのC7の名前と完全一致する文字列の右隣のセルがい　をブックA.xlsmのP4 : S8の範囲でカウントし、ブックBのあシートのZ7に表示。
　　　　　　同上　　　　　C8 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Z8　　　。
　　　　　　同上　　　　　C9 　同上　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　Z9　　　　。

以下同様に　ブックBのう～このシートで行う。

さらに、上記の行いたいことがマクロで可能であれば、
ブックAの2シートになると、X7に表示していたのがAB7に表示したい。同様にY7→AC7　、Z7→AD7　となります。
ブックAの3シートになると、AF7　、AG７、AH７と変わっていきます。
やはり、マクロを手動で書き換えるしか方法がないのでしょうか？
やはり説明が苦手です。　

＜使用 Excel：Excel2010、使用 OS：WindowsXP ＞

 文章読むの苦手で、解読に時間掛かりましたがこういうことでいいですか？
 ブックA、ブックBともに開いている状態です。
    Option Explicit

    Sub test()
        '//[必須]ツール＞参照設定＞Microsoft ScriptingRuntime
        Dim dic(2) As Dictionary
        Set dic(0) = New Dictionary
        Set dic(1) = New Dictionary
        Set dic(2) = New Dictionary

        Dim rng(2) As String
        rng(0) = "F4:K8"
        rng(1) = "L4:O8"
        rng(2) = "P4:S8"

        '//日付単位で出力しよう
        Dim shA As Worksheet
        Dim tbl As Variant
        Dim i As Long, r As Long, c As Long
        Dim id As String, cd As String
        Dim dt As Double
        Dim k As Variant
        For Each shA In Workbooks("A.xlsm").Sheets '★
            dic(0).RemoveAll
            dic(1).RemoveAll
            dic(2).RemoveAll
            For i = 0 To 2
                tbl = shA.Range(rng(i)).Value
                For r = 1 To UBound(tbl, 1)
                    For c = 1 To UBound(tbl, 2) Step 2
                        id = tbl(r, c)     '//名前
                        cd = tbl(r, c + 1) '//コード
                        If id <> "" And cd <> "" Then
                            If Not dic(i).Exists(cd) Then Set dic(i)(cd) = New Dictionary
                            dic(i)(cd)(id) = dic(i)(cd)(id) + 1
                        End If
                    Next c
                Next r
            Next i

            dt = shA.Range("C2").Value
            With Workbooks("B.xlsm") '★
                For i = 0 To 2
                    For Each k In dic(i).Keys
                        With .Sheets(k)
                            .Activate
                            c = Application.WorksheetFunction.Match(dt, .Rows(4), 0) '日付で4行目を検索
                            For r = 7 To .Cells(Rows.Count, "C").End(xlUp).Row       '7行目から最後の行まで
                                id = Cells(r, "C").Value
                                If dic(i)(k).Exists(id) Then
                                    Cells(r, c + i).Value = dic(i)(k)(id)
                                End If
                            Next r
                        End With
                    Next k
                Next i
            End With
        Next shA
        Set dic(0) = Nothing
        Set dic(1) = Nothing
        Set dic(2) = Nothing
    End Sub
（稲葉） 2017/08/05(土) 15:39

稲葉様　返信が遅くなり申し訳ありません。試しに動かしていました。
出来ないと思っていたことが、思い描いた通りに動いています。言葉では言い表せないくらいびっくりしているのと同時に嬉しく思っています。ブックAのシート1のC２の日付を変更することでブックBの転帰先を変更できることに、ただただ驚いています。

ブックAのシート1から、ブックBの各シートに転帰だけでなく、ブックC、ブックDにも同様の条件があれば転帰させたいのですが、そのときはどう記載すればよろしいのでしょうか？シートの数は変動します。

（まさこ） 2017/08/05(土) 21:09

 ブックAの内容をC Dのブックにも、ということですか？
 そうなるとループがひとつ増えますねえ
 あと、ミスが一ヵ所あったので再掲します
 少しお待ちください
（稲葉） 2017/08/06(日) 05:49

 書いていて思ったのですが、同じ内容ならBブックをコピーでもよいような？
 あと注意事項書き忘れていましたが、
 Aブックに名前があって、Bブックに名前が無い場合は、Bブックに出力されていません。
 同様に、Aブックにコードがあって、Bブックのシートにコードが無い場合も出力されません。というかエラーになります。

    Option Explicit
    Sub test()
        '2017/8/7　13:35 編集にて差し替えました
        '//[必須]ツール＞参照設定＞Microsoft ScriptingRuntime
        Dim WBa As Workbook
        Set WBa = Workbooks("A.xlsm")

        Dim WBb(2) As Workbook
        Set WBb(0) = Workbooks("B.xlsm")
        Set WBb(1) = Workbooks("C.xlsm")
        Set WBb(2) = Workbooks("D.xlsm")
        'ここまででエラーが出たら、ブックが開かれていない。

        Dim dic(2) As Dictionary
        Set dic(0) = New Dictionary
        Set dic(1) = New Dictionary
        Set dic(2) = New Dictionary
        Dim rng(2) As String
        rng(0) = "F4:K8"
        rng(1) = "L4:O8"
        rng(2) = "P4:S8"
        '//日付単位で出力しよう
        Dim shA As Worksheet
        Dim tbl As Variant
        Dim i As Long, r As Long, c As Long
        Dim id As String, cd As String
        Dim dt As Double
        Dim wb As Long
        Dim k As Variant
        Dim shB As Worksheet
        Dim ErrNum As Long

        For Each shA In WBa.Sheets
            If shA.Range("C2").Value = "" Then
                '日付セルが空白なので、何もしない
            Else
                '日付セルが空白以外なので、処理を継続
                dic(0).RemoveAll
                dic(1).RemoveAll
                dic(2).RemoveAll
                For i = 0 To 2
                    tbl = shA.Range(rng(i)).Value
                    For r = 1 To UBound(tbl, 1)
                        For c = 1 To UBound(tbl, 2) Step 2
                            id = tbl(r, c)     '//名前
                            cd = tbl(r, c + 1) '//コード
                            If id <> "" And cd <> "" Then
                                If Not dic(i).Exists(cd) Then Set dic(i)(cd) = New Dictionary
                                dic(i)(cd)(id) = dic(i)(cd)(id) + 1
                            End If
                        Next c
                    Next r
                Next i
                dt = shA.Range("C2").Value
                For wb = 0 To UBound(WBb)
                    For i = 0 To 2
                        For Each k In dic(i).Keys
                            Set shB = Nothing
                            ErrNum = 0
                            On Error Resume Next
                                Set shB = WBb(wb).Sheets(k)
                                ErrNum = Err.Number
                            On Error GoTo 0
                            If ErrNum > 0 Then
                                'シートがないので何もしない
                            Else
                                'シートがあるので集計を入力する
                                c = Application.WorksheetFunction.Match(dt, shB.Rows(4), 0) '日付で4行目を検索
                                For r = 7 To shB.Cells(Rows.Count, "C").End(xlUp).Row       '7行目から最後の行まで
                                    id = shB.Cells(r, "C").Value
                                    If dic(i)(k).Exists(id) Then
                                        shB.Cells(r, c + i).Value = dic(i)(k)(id)
                                    End If
                                Next r
                            End If
                        Next k
                    Next i
                Next wb
            End If
        Next shA
        Set dic(0) = Nothing
        Set dic(1) = Nothing
        Set dic(2) = Nothing
    End Sub

（稲葉） 2017/08/06(日) 06:33

稲葉様　度々ありがとうございます。今、色々試しに実行しています。思い描いた通りなので、とてもうれしい限りです。うれしくて、何度も動いているのを眺めてしまいます。
　　
Microsoft ScriptingRuntimeにチェックをいれる理由が、
FileSystemObjectオブジェクトはScriptingに属し、VBAの枠外に存在するためそのままではVBA上で使用することができないからであり、トライブやフォルダを操作するため。何となくしか理解出来ていません笑
　　　
　同じ内容ならBブックをコピーでもよいような？
　＞全く同じ内容ではなくて、ブックBの氏名とコードの条件を、ブックC、ブックDにもループさせて、ブックAにて探したかったのです。氏名とコードが全く同じ内容は、ブックB、C、Dにはありません。

（まさこ） 2017/08/06(日) 07:43

 えーと、解決でよろしいですか？
 やってることは、ブックＡにあるものをBCDに集計させていますので
 ブックＡにて探す、という表現はちょっと語弊があります

 また、全く同じ内容がないということは、ブックＡにあって、BCDにない
 コード（シート）があると思うのですが、問題なく動いていますか？
（稲葉） 2017/08/06(日) 08:50

稲葉様　
自分なりにコードを理解して、解決しようしてたら返信が遅くなってしまいました。

ブックAにあるものを集計＞表現の語弊すみません。

With WBb(wb).Sheets(k)　にてインデックスが有効範囲にありませんとエラーがでてしまいます。

ここでエラーがでたらシートがないということでしたが、

ブックAにあって（氏名と右隣のコード）、BCDのどれかブックに氏名がある、かつ、シートがコードの名前になっているのですが。

ブックBCDは、それぞれシートの数もバラバラです。ブック間ではシート名前は重複している物もあれば、重複していないものもあります。しかし、ブックAにある氏名と右隣コードは、必ずBCDの、どれかにはC7以降に氏名が、シートの名前がコードの物が存在しています。
（まさこ） 2017/08/07(月) 00:11

エラーの対処できた後の話ですが、例えば、ブックAの対象とするシートの名前を指定して、上記と同じ方法でBCDに集計させたいことも教えて頂けると嬉しいです。
一つ前のコメのエラーに関してイミディエイトウィンドウをみてはいるのですが。みているだけなのですが混乱してきました。
（まさこ） 2017/08/07(月) 01:01

稲葉様　すみませんでした。思っていた通りに動きました、何故か混乱していました。
上記のコメを削除できないのが不便です。本当にありがとうございました。

最後に私のこのマクロの認識が合っていれば、一点だけ修正をお願いした後に、一旦解決とさせて頂きたいです。
・例えば、ブックAに氏名があり、その右隣のセルが　あ　とします。
ブックBのシートあ　でブックAの氏名があった場合、出力されました。しかし、ブックBのシートい　に氏名があるにも関わらず、シートあ　が存在する為に、エラーは回避されてしまいました。この場合にエラーコードを出したいです。

そして、もしも最後にわがままを聞いて下さるならば、以下のことを実現させたいです。
ブックAに入力する名前が、ブックBCDのC7以降のどのシートにもなかった場合(完全一致しなかった場合)、入力エラーのメッセージを出したい（私にはチェンジイベントしか思いつかないですが）
または
ブックAの入力がすべて終わった時に、マクロを実行すると仮定。
BCDの各シートのC7以降の氏名と完全一致しない氏名が、ブックAのアクティブのシートに入力されていれば、ブックAの氏名が入力されているセルの背景色を赤色に塗りつぶしたい。
（まさこ） 2017/08/07(月) 03:17

 ◆処理の流れ
 ブックA　9/1シートを開く
 　　F4:K8の範囲でループし、下記のような入れ物を作る
 　　　　F4:K8
 　　　　　├あ
 　　　　　│├大阪太郎─３
 　　　　　│└滋賀花子─１
 　　　　　└い
 　　　　　　├大阪太郎─１
 　　　　　　└三重太郎─１
 　　ブックBを開く
 　　　　「あ」シートを開く　←このシート名は２つめの入れ物、ループする。（あ→い）
 　　　　　　C7から最終行まで見て、入れ物の名前と一致したら、カウントした数値を入れる
 　　ブックCを開く
 　　　　「あ」シートを開く　←このシート名は２つめの入れ物、ループする。（あ→い）
 　　　　　　C7から最終行まで見て、入れ物の名前と一致したら、カウントした数値を入れる
 　　ブックDを開く
 　　　　「あ」シートを開く　←このシート名は２つめの入れ物、ループする。（あ→い）
 　　　　　　C7から最終行まで見て、入れ物の名前と一致したら、カウントした数値を入れる
 ブックA　9/2シートを開く
 以下繰り返し

 ＞ブックBのシートあ　でブックAの氏名があった場合、出力されました。
 ＞しかし、ブックBのシートい　に氏名があるにも関わらず、シートあ　が存在する為に、エラーは回避されてしまいました。
 上記処理の流れから、ありえません。
 シートが存在しなければ、飛ばす処理は可能です。

 ＞（略）エラーのメッセージを出したい
 ＞（略）セルの背景色を赤色に塗りつぶしたい。
 少なくとも、私には無理です。
 入力のたびに３つのブックのすべてのシートをループさせるなんて現実的ではないと思います。
 提案ですが、入力開始前にブックAに氏名チェック用シートを作成し、条件付書式で対応が望ましいと思います。
（稲葉） 2017/08/07(月) 10:46

稲葉様　
処理の流れのとても丁寧な説明ありがとうございます。頂いたマクロを実行後に、処理内容にイレギュラーが生じるケースは、まれにあるため、その時はBCDに集計処理した事を少し手作業で変更する予定の運用なのです。

完了した手作業の変更を上書きされないために、
・ブックAのそれぞれのシートを開いた時に、C2に日付が空白の場合は処理を飛ばす。ということも是非とも教えて頂きたいです。
そして
・ブックBCDにシートが存在しなければ、飛ばす処理は可能ということですが、是非とも教えて頂きたいです。

実は、処理内容は膨大な量があり、数十人がブックABCDに入力していて、それを毎日チェックして、処理するという流れが大まかな実務の流れですので、大幅な時間の短縮になりそうです。感謝してもしきれないくらいです。なんとお礼を言っていいのやら。

 ＞（略）エラーのメッセージを出したい
 ＞（略）セルの背景色を赤色に塗りつぶしたい。
ご提案ありがとうございます。条件付き書式で対応することにします。

（まさこ） 2017/08/07(月) 12:00

 ＞完了した手作業の変更を上書きされないために
（稲葉） 2017/08/06(日) 06:33 の投稿を差し替えましたので、ご確認ください。

 ＞ご提案ありがとうございます。条件付き書式で対応することにします。
 とのことでしたので、BCDブックにある氏名を書き出すコードです。
 Aブックに新しいシートを作って、シートモジュールに入れてください。
    Option Explicit

    Sub 氏名一覧作成()
        '//[必須]ツール＞参照設定＞Microsoft ScriptingRuntime
        '//[必須]ブックAの氏名一覧を書き出したいシートモジュールに貼り付ける
        Me.Activate 'シートモジュール以外だとエラーになる

        Dim WBb(2) As Workbook
        Set WBb(0) = Workbooks("B.xlsm")
        Set WBb(1) = Workbooks("C.xlsm")
        Set WBb(2) = Workbooks("D.xlsm")
        'ブックを開いていないとエラーになる

        Dim dic As Dictionary
        Set dic = New Dictionary

        Dim i As Long
        Dim sh As Worksheet
        Dim r As Long
        For i = 0 To UBound(WBb, 1)
            For Each sh In WBb(i).Sheets
                For r = 7 To sh.Cells(Rows.Count, "C").End(xlUp).Row       '7行目から最後の行まで
                    dic(sh.Cells(r, "C").Value) = ""
                Next r
            Next sh
        Next i
        Me.Cells.ClearContents
        Me.Range("A1").Resize(dic.Count).Value = Application.Transpose(dic.Keys)
        Set dic = Nothing
    End Sub
（稲葉） 2017/08/07(月) 13:38

稲葉様
2017/08/06(日) 06:33 の投稿を確認致しました。
そして、BCDブックにある氏名を書き出すコードまで教えて頂いてありがとうございます。
大満足です。とてもとても解決いたしました。
本当であれば直接会ってお礼を言いたいくらいです。私の為に、お時間を割いていただいて本当にありがとうございました。
（まさこ） 2017/08/07(月) 13:57

 弊社は月月火水木金金なので、残念ですがお会いできそうにないですね。ごめんなさいね。（冗談です）
 お礼一言あれば、満足です。

 お仕事がんばってください。
（稲葉） 2017/08/07(月) 16:15

コメント返信：

[ 一覧(最新更新順) ]

[[20170804215608]] 『複数条件のカウントを転帰 日付が変わると転帰場』（まさこ） ページの最後に飛ぶ

[[20170804215608]]　『複数条件のカウントを転帰　日付が変わると転帰場』（まさこ）　ページの最後に飛ぶ