[[20120731144914]]　『変更前・変更後のデータを別シートへ』（UMI）　ページの最後に飛ぶ

『変更前・変更後のデータを別シートへ』（UMI）
Windows 7

 はじめまして。VBA初心者で、こちらを参考にさせて頂き、色々と試してはいるのですが、なかなかうまくいきません(>_<)
 職場先で毎回食数の変更を行っており、シート①の週間表で食数の管理をしています。
 変更があれば、シート①へ書き込み、それと同時に変更箇所のみ(日付・変更前の個数・変更後の個数)をシート②へ記載し、他の業者へ送らなければなりません。
（A食B食C食とは食事形態です・・）
 シート①の変更前と変更後をシート②へ反映させることは可能でしょうか？(シート①には常に新しい情報が記載された状態です）
他にはユーザーフォームを使う方法も考えたのですが、なかなか前に進みません・・
 説明下手ですみません。何かスムーズに行える方法がありましたら、ご教授お願いいたします。どうかよろしくお願いします。

 (シート①　週間表）
    A　  B　 C 　　D 　　E　　 F 　　G 　　H　　 I 　　J　 　K 　　L  ・・・
 1　月日　　　　　　　７月23日　　　　　７月24日　　　　　７月25日　 ・・・　
 2　曜日　　　　　　　  　月　　　　  　　　火　　　    　　　水　　  ・・・　  
 3
 4  形態          　A食　B食　C食     A食　B食　C食    A食　B食　C食
 5  個数             3    2    5       4    1    6      2    1    7

 (シート②　変更届)

        A  　 B  　 C  　　　D  　　 E  　　　F 　 　 G  　　 　H  　　 L　 　
 1      月　　日　　曜日　　　　A食　　　　　　　B食　　　　　　　　C食
 2　　　　　　　　　　　　変更前　変更後　　変更前　変更後　　変更前　変更後　
 3     　7　　23　　月　　　２　　　３　　　　
 4　　　 7    25    水                        ２　　　１
 5

 いくつは方法はある。
 １．最初に（朝一番とか、とにかく変更前に）シートをコピーしておき、変更前シートといったシート名にしておいて
　　最後に（他の業者に送る直前に）変更前シートと変更後シートを比較してその値が変更前シートの該当の値と異なれば
　　変更届シートに転記。
 ２．同じく、変更前シートをコピーして作っておき、変更があった時点で、そのイベントで、その値が変更前と異なれば、
　　変更届シートに、その項目を転記。
　　（入力後、間違いだったと言うことで元に戻す場合も想定すると、値が同じであれば変更届の該当の場所を空白に）

 他に、変更前のコピーを作らず、変更入力のイベントで、変更前、変更後の値を取得することができるので
 そこで、比較して変更届に書くことも考えられるけど、２．でふれたように、100 を 120 に変更し、さらに 
 120 を 100 に変更すると、『変更された』とみなされるので、まぁ、１．か２．だろうね。

 ところで、変更されるのは数値だけと考えていい？
 つまり、キーというか、月日とか、曜日とか、形態なんてのは変更されないと考えていいね。
 さらに、追加もないね。

 (ぶらっと)

ぶらっとさん、早々な返信どうもありがとうございます！
はい、変更は数値だけです。
いくつか方法はあると聞いて、少しほっとしました。
2の場合はどのように進めたらいいのでしょうか？
右も左もわからず、すみません。。

 レイアウトは以下という前提

 （週間表）
 ・１行目、日付はD1,G1,J1,・・・・に日付型でセットされている。３列ずつ結合されていてもいなくてもＯＫ
 ・２行目の曜日もD2,G2,J2,・・・・にセットされている。ここも結合されていてもされていなくてもＯＫ
 ・１つの日付は３列単位。（A食、B食、C食)
 ・入力者は５行目の数字を変更する。

 （変更前）

 その日の変更入力の前にかならず"変更前"シートを作成しておくこと。

 （変更届)

 ２行目まであらかじめ設定済み。マクロでは３行目以降だけに処理結果を書き込む。

 で、週間表シートのシートモジュールに（シートタブを右クリック -> コードの表示）以下を貼り付け。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x As Long
    Dim c As Range
    Dim tRow As Long
    Dim abc As Long
    Dim mm As Long
    Dim dd As Long
    Dim wd As String

    x = Cells(1, Columns.Count).End(xlToLeft).Column
    Set c = Intersect(Target, Range("D5", Cells(5, x + 2)))
    If c Is Nothing Then Exit Sub

    If c.Count > 1 Then
        MsgBox "数値変更は、単一セルだけにしてください" & vbLf & "入力を取り消します"
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
        Exit Sub
    End If
    abc = (c.Column - 4) Mod 3
    x = ((c.Column - 4) \ 3) * 3 + 4
    mm = Month(Cells(1, x).Value)
    dd = Day(Cells(1, x).Value)
    wd = Cells(2, x).Value

    With Sheets("変更届")
        tRow = getRow(mm, dd)
        If c.Value <> Sheets("変更前").Range(c.Address).Value Then
            .Cells(tRow, "D").Offset(, abc * 2 + 1).Value = c.Value
            .Cells(tRow, "D").Offset(, abc * 2).Value = Sheets("変更前").Range(c.Address).Value
            .Cells(tRow, "A").Value = mm
            .Cells(tRow, "B").Value = dd
            .Cells(tRow, "C").Value = wd
        Else
            .Cells(tRow, "D").Offset(, abc * 2).Resize(, 2).ClearContents
        End If

        With .Rows(tRow)
            If WorksheetFunction.Count(.Range("D1:I1")) = 0 Then .Delete
        End With
    End With
 End Sub

 Private Function getRow(mm As Long, dd As Long) As Long
    Dim x As Long
    Dim i As Long

    With Sheets("変更届")

        x = .Range("A" & .Rows.Count).End(xlUp).Row
        If x < 3 Then
            x = 3
        Else
            For i = 3 To x
                If .Cells(i, "A").Value = mm And .Cells(i, "B").Value = dd Then
                    x = i
                    Exit For
                End If
            Next
            x = i
        End If

        getRow = x

    End With

 End Function

 (ぶらっと)

 ぶらっとさん、ありがとうございます！
 出来ました！　かなり感動です！

 もう少しすみません、週間表の数字入力、上では５行目となっていますが、他の行に変える場合は、
 どこをどう変えたらいいのでしょうか？　少しやってみましたがうまくいきませんでした。

 あと、今の分を昼食用とした場合、夕食分を同じシート内に作ることは可能でしょうか？
 ややこしくなりますかね?

 例えば、(週間表)では今作ってあるものを昼食分とし、その下に夕食分を。
　　　　(変更届)では、左は昼食、その右側に同じ書式で夕食分といった感じです。
 お忙しい所すみません。よろしくお願いします。　(UMI)

 とりあえず行の変更。

 Set c = Intersect(Target, Range("D5", Cells(5, x + 2)))

 この D5 と Cells(5, が５行目をあらわしている。なので、たとえば６行目なら

 Set c = Intersect(Target, Range("D6", Cells(6, x + 2)))

 昼食・夕食分は後程。

 ところで夕食分を加えるということは、レイアウトが変更になるということで、変更届を送付する相手先にも影響？
 レイアウトを変更しても相手先で問題がでないのなら、いっそのこと、今、Ａ列に月、Ｂ列に日となっているけど
 データ処理としては、年があったほうが絶対にいいので、Ａ列を日付型の年月日にしてはいかが？
 (表示形式は、必要なら m"月"d"日" とセットしておく）

 (ぶらっと)

返信ありがとうございます！やってみます。
レイアウトが変わっても、わかれば良いということなので送付先には問題ありません。
おっしゃる通り、年月日にした方がいいかもですね。
ありがとうございます (UMI)

 とりあえず、現行通り、変更届の月日は日付型ではなく単なる数字というバージョン。
 夕食用入力をカバーするつぃでに、レイアウト要件をほとんど、先頭の　Const で規定。
 たとえば、将来、A,B,C食に加えD食が追加になったとか、朝、昼、夕になったとか、そういう場合
 レイアウトを直した後、このConst規定を直せば、コードの中身はいじらなくてもいい（と思う）

 以下は夕食追加で、入力行は６行目と７行目という規定。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Const DateRow As Long = 1   '日付行番号
    Const DateCol As Long = 4   '日付開始列 D
    Const TypeNos As Long = 3   '形態（A,B,C等)数
    Const qtyRow As Long = 6    '個数開始行
    Const QtyLines As Long = 2  '入力行の数（昼食、夕食等）

    Dim x As Long
    Dim c As Range
    Dim tRow As Long
    Dim abc As Long
    Dim mm As Long
    Dim dd As Long
    Dim wd As String

    x = Cells(1, Columns.Count).End(xlToLeft).Column
    Set c = Intersect(Target, Range(Cells(qtyRow, DateCol), Cells(qtyRow, x + TypeNos - 1)).Resize(QtyLines))

    If c Is Nothing Then Exit Sub

    If c.Count > 1 Then
        MsgBox "数値変更は、単一セルだけにしてください" & vbLf & "入力を取り消します"
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
        Exit Sub
    End If
    abc = (c.Column - DateCol) Mod TypeNos
    x = ((c.Column - DateCol) \ TypeNos) * TypeNos + DateCol
    mm = Month(Cells(DateRow, x).Value)
    dd = Day(Cells(DateRow, x).Value)
    wd = Format(Cells(DateRow, x).Value, "aaa")

    With Sheets("変更届")
        tRow = getRow(mm, dd)
        If c.Value <> Sheets("変更前").Range(c.Address).Value Then
            .Cells(tRow, "D").Offset(, 2 * TypeNos * (c.Row - qtyRow) + abc * 2 + 1).Value = c.Value
            .Cells(tRow, "D").Offset(, 2 * TypeNos * (c.Row - qtyRow) + abc * 2).Value = Sheets("変更前").Range(c.Address).Value
            .Cells(tRow, "A").Value = mm
            .Cells(tRow, "B").Value = dd
            .Cells(tRow, "C").Value = wd
        Else
            .Cells(tRow, "D").Offset(, 2 * TypeNos * (c.Row - qtyRow) + abc * 2).Resize(, 2).ClearContents
        End If

        With .Rows(tRow)
            If WorksheetFunction.Count(.Range("D1").Resize(, TypeNos * 2 * QtyLines)) = 0 Then .Delete
        End With
    End With
 End Sub

 Private Function getRow(mm As Long, dd As Long) As Long
    Dim x As Long
    Dim i As Long

    With Sheets("変更届")

        x = .Range("A" & .Rows.Count).End(xlUp).Row
        If x < 3 Then
            x = 3
        Else
            For i = 3 To x
                If .Cells(i, "A").Value = mm And .Cells(i, "B").Value = dd Then
                    x = i
                    Exit For
                End If
            Next
            x = i
        End If

        getRow = x

    End With

 End Function

 (ぶらっと)

 補足

 将来、週間表のレイアウトを変更する場合、そのままでは、レイアウト変更作業中にイベント処理が走る。
 これでは、具合が悪いので、
 ・マクロ無効で開いてレイアウト変更
 ・マクロ有効にして開くなら、以下のコードを標準モジュールに書いておいて、実行してからレイアウト変更。
　レイアウト変更が終われば、もう一度、実行。（これでイベントが再開）

 Sub SetEvent()
    Application.EnableEvents = Not Application.EnableEvents
 End Sub

 (ぶらっと)

 ぶらっとさん、ありがとうございます！(>_<)
 ばっちりできました！!
 すみません、仮に週間表の数字入力部分に数式？(マクロ？)なんかを入れて数字を出すようにしても、同じように作動しますか？　それとも数字と認識されないのでしょうか？
 少しやってみたのですが、変更シートにうまく反映されないもので・・

 コードは、6行目か7行目の個数入力欄に『値であれ式であれ、入力されたら』反応する。
 たとえば D6 に　=A20 といれれば、A20の値がD6に入力されたのと同じ結果になる。
 ただし、=A20と入っているものに対し、『A20』の値を変えると D6　の値も変わるけど、この場合は
 反応しない。（入力されたのは、あくまで A20 で、D6は計算されただけなので）

 もし入力欄(６行目と7行目）のセルに計算式が入っていて、そこが計算されたときも反応させるなら
 できないことはないけど、コードは少し変えなきゃいけない。

 具体的に、どんな式がはいっているの？

  (ぶらっと)

 早々な対応ありがとうございます。　（UMI）
 式は、COUNTIFです。
 週間表の曜日と数字入力の間に数ヶ所○を入れ、それをCOUNTIFを使い○の数だけ数字入力の行に反映という形をやってみたのですが、、

 方法は

 １．現在は６行目と、７行目の入力欄に入力されたらというロジックだけど、それを
　　○を入れるセルに入力されたらというロジックに変える。
    この場合、○を入れる場所を具体的に教えてもらわなければいけない。
    (というか、その具体的な数式をアップしてもらった方が早いかな）
 ２．『シート上で計算されたら』というロジックにかえたうえで、入力欄の値を保存しておき、
　　入力欄の値と保存しておいた値がかわったところを変更セルとみなす。
 ３．今、=COUNTIF という関数だとして、それをユーザー定義関数というものにする。
　　こうすると、どのセルで計算がされたかの把握ができるので、現在のロジックとの親和性がある。
    この場合も、具体的な数式をおしえてもらわなければいけない。

 まぁ、おすすめは、１．その次が３．一番面倒なのは２．
 とにかく、式をアップしてくれる？

 だけど・・・数字を入れるより、○をいれるほうが、ほんとに、運用上、簡単なの？
 10個なら○を10個入力？それより、10とタイプした方が絶対に簡単で間違いがないんじゃないの？

 (ぶらっと)

数式は、週初め月曜のA食の下(D24)に、=COUNTIF(D4:F6,"〇")
　　　　　　　　　　B食の下(E24)に、=COUNTIF(D7,"〇")
　　　　　　　　　　C食の下(F24)に、=COUNTIF(D8:F22,"〇")
　　　　　　　火曜　　　　 (G24)に、=COUNTIF(G4:I6,"〇")
　　　　　　　　　　　　　 (H24)に、=COUNTIF(G7,"〇")

                           (I24)に、=COUNTIF(G8:I22,"〇")
              水曜         (J24)に、=COUNTIF(J4:L6,"〇")
                           (K24)に、=COUNTIF(J7,"〇")
                           (L24)に、=COUNTIF(J8:L22,"〇")
              木曜         (M24)に、=COUNTIF(M4:O6,"〇")
                           (N24)に、=COUNTIF(M7,"〇")
                           (O24)に、=COUNTIF(M8:O22,"〇")
              金曜         (P24)に、=COUNTIF(P4:R6,"〇")
                           (Q24)に、=COUNTIF(P7,"〇")
                           (R24)に、=COUNTIF(P8:R22,"〇")
              土曜         (S24)に、=COUNTIF(S4:U6,"〇")
                           (T24)に、=COUNTIF(S7,"〇")
                           (U24)に、=COUNTIF(S8:U22,"〇")
              日曜         (V24)に、=COUNTIF(V4:X6,"〇")
　　　　　　　　　　　　　 (W24)に、=COUNTIF(V7,"〇")
　　　　　　　　　　　　　 (X24)に、=COUNTIF(V8:X22,"〇")　といった感じです。

 ○、×、をダブルクリックで表示出来るようにし、食事形態別に○だけ反映できたらと思いまして。。

       月火水木金土日　　　　　
 (名前)○○○×○××
 (名前)○○○○×○×
　
　という具合です。　　　（UMI）

  う～ん・・・理解できるようで、できないようで・・・（というか、ますますわからなくなった・・・）
 この数式が相手にしている、最終の、そちらの週間表のレイアウトがわからないんだけど
 (名前) って、食事を申し込んだ田中さんとか木村さん？   もし、そうだとして。

 D24のCOUNTIF(D4:F6,"〇")。D4:F6の3行3列はこちらが理解しているレイアウトによれば、月曜日のA,B,Cのタイトル行と、その下の２行３列の個数欄。
 この領域の○の数は0～6のはず。この0～6って、何を意味しているの？
 さらに、5行目、6行目は『個数としての数字』だったはずだけど、ここが"○"かどうかを判定すると言うことは、数字じゃなくなった？
 なら、そもそも、ここを『数字』として処理しているアップ済みコードは使えなくなるよ？

 E24のCOUNTIF(D7,"〇")。　7行目が何なのかわからないんだけど、少なくとも、この数式でできる数は 1 か 0　。
 この 1 か 0 は何を表しているの？

 F24のCOUNTIF(D8:F22,"〇")。8行目から22行目に田中さん、木村さん、・・・と個人別の食事申し込み行？
 とすると、D28:F22は月曜日の食事数？

 D24,E24,F24は、こちらの理解ではA,B,C食の列にあるけど、上記のように、その列のA,B,Cに対する数字ではないようだし？
 で、この数式構想では,A,B,C食は、どのように管理する？また、昼食、夕食はどのように管理する？

 もし、やりたいことが、

 ・今までと同じレイアウトの週間表（および、変更前）があって、それとは別に、個人別、曜日別のマトリックスがあって
   (同じシートでも別シートでもいいけど）
 ・マトリックス表のセルをダブルクリックして"○"にしたり空白にしたりする。
 ・その結果を週間表の５行目、6行目の個数欄に数式を入れておいて数字として取得する。
 ・その数字として取得した結果を変更届の元ネタにする。

 ということなら、わからないでもないけど、でもそうだとすると、山田さんの月曜日に対して１つだけじゃなく
　Ａ，Ｂ，Ｃ（３） X 昼食、夕食（２）　で　６つの欄が必要だけど、それは、どんなレイアウトなの？

 今考えている要件をもう一度、（処理手順も考慮した上で、）よく考えて整理して、レイアウトも含めて
 説明してもらえる？

 (ぶらっと)

 ですよね、、すみません。今まで手書きで行ってた作業をどうにか組み込めないかと思いまして、書いてしまいました。
 ややこしくなってしまい申し訳ありません。。
 それと、お忙しい中コメントありがとうございますm(_ _)m

 うまく説明できるかわかりませんが、

 現在のレイアウトは、

 ・A列には縦に昼食の文字
 ・B列は4～6行がA食、7行目がB食、8～22行目がC食になっています（A食、B食、C食は、それぞれソフト食、
   糖尿食、普通食などの食事形態を示しています）
 ・C列に名前
 ・D～Fをセル結合で、上から2行目が月日、3行目が曜日、4～22行目はダブルクリックで○や×が付くようになってます。
 ・23行目には、A食、B食、C食の文字が入り
 ・24行目には、上記のそれぞれの個数が入ります。（すみません、以前のレイアウトの5　行目、6行目の『個数としての数字』を24行目に変えました。）

 ・A食は、４～６行で３人、
 ・B食は、７行で１人、
 ・C食は、８～２２行で、１５人分の欄があります。（入る人数は週によって異なります）

 個人の１週間分の食事数を管理できるよう、名前の横にダブルクリックで○×がつくようにし、
 24行目の個数の所にCOUNTIFを使い、○の部分(発注数)だけ、それぞれの食事形態の個数が反映されるようにしています。
 夕食分は人が変わるので、昼食と同じ要領で、昼食分の下に作れたらと思っています。

 最終的にはA食・B食・C食の個数が、作って頂いた変更届けに反映されればと思っているのですが、COUNTIFで反映された数字を、変更届へ反映することができずにいました。

 説明下手ですみません。。

   A      B 　　　 C　 　   D　　　E　　　F　　　　　　G 　 　H 　 　I 　 　　J　　 K 　  L　　
 1
 2　　　　　　　　　　　　　   7月23日　　　　　　 　     7月24日　　　　　　　 　7月25日
 3　　　  　　　　　            （月）	　　　　   　      （火）　　  　　　　    （水）
 4　　　 A食　　木村様      　    ○　　　　　　　    　　   ○ 　　　　　　　　　   ○　
 5昼　　　　　　田中様 　　  　   ×                   　　  ○                 　　 ×
 6　　　 　   　 　
 7食　　 B食
 8～22   C食
 23                      A食　　　B食　　C食　　　　A食　　B食　　C食　　　 　A食    B食　　C食
		     　　 2       1      5	   　 3      1      6           3      1      7

（UMI）

 かなりわかった。
 ところで、個人別の欄だけど、
 昼・夕->形態->個人->日ごとの、この形態の要否 というレイアウトだけど、（もちろん、これでもいいけど）
 コード処理を考えると、形態については集計欄と同じような構成、つまり
 昼・夕->個人->月のA,B,C->火のA,B,C->・・・・
 こうするのは無理かな？
 個人別欄の行数も節約できるし、いいんじゃないかな？

 (ぶらっと)

 読んで頂きありがとうございますm(_ _)m
 月のA,B,C->火のA,B,C->・・・・
 どんな感じになるんですかねぇ？?
 すみません、イメージ力が乏しくて。。

 (UMI)

 つまり個人別の1行のイメージが２４行目と同じようなレイアウトになるということ。

 ちなみに、そちらで考えたレイアウトでもできないことはないけど、
 ・どこからどこがA食で、どこからどこがB食で　というConst規定を昼夕それぞれに規定してもらわなければいけない。
 ・あるいは、個人別欄のＢ列の形態のなかから、自分の行が紐つく行の文字列を探し出して２３行目とマッチングさせて求めなきゃいけない。

 やるなら前者だけど、これも Const規定がやたら煩雑になるのでやりたくない。
 後者は、コードが面倒だからやりたくない。

 (ぶらっと)

 なるほどですねー！ありがとうございます。
 レイアウト理解できました！

 (UMI)

 いやぁ、ロンドン。日本はがんばってるねぇ！！
 おかげで、すっかり寝不足。

 なんとかコードができあがったと思う。
 コードのアップの前に、この仕組みは、『気をつけて使わなくてはいけない』ので
 そのあたりのメモを。

 ・前にコメントしているけど、レイアウトを修正したり、処理を動かさずにシートの内容を変更したい場合
   イベントの発生を抑止しなければいけないので、
   SetEvent　実行　-->　シート上の作業　-->　SetEvent　実行
 ・さらに、今回、ブックを開く際のイベントで準備処理を行っているので、コード変更を行った後は
   いったんブックを保存して閉じて、再度、開いて使用してほしい。

 で、そちらの運用が見えないけど、こちらでテスト確認した経験から以下のような流れがいいのではと思う。

 1週間分のデータを作成するにあたり

 １）SetEvent　実行
 ２）週間表シートの個人の○を入れる領域をクリア
 ３）週間表シートの合計個数欄をクリア。（後述するけど、ここには計算式をいれず、マクロが計算結果をいれる）
 ４）SetEvent　実行
 ５）個人別の○を入れて週間表シートを仕上げる。

 これで、週間表シートが確定したら

 ６）上記の５）で、マクロが動いて変更届が作られているので、その3行目以降をクリア
 ７）変更前シートに週間表シートのイメージをコピペ。

 以降、変更入力があれば、『正しい変更届け』が作成される。

 さて、コード。
 従来の　Const QtyLines As Long = 2  '入力行の数（昼食、夕食等）を　Dim QtyLines As Long　として、値はマクロ内で生成。
 新たに、Dim PBlocks As Variant　を用意し、PBlocks = Array(5, 2)       '個人別欄の昼食用人数,夕食用人数　夜食ができれば Array(5,2,4) とか
 これで、昼、夕等の数と、それぞれの個人数の規定を行っている。
 また、Const PRow As Long = 4      '個人別入力開始行　を追加してある。

 それと、上でもコメントしたけど、24行目や25行目の数式は不要なので消しておいて。

 現在のシートモジュールのコードはすべて削除。
 かわりに、ThisWorkbookモジュールに以下を。

 Option Explicit

    Const DateRow As Long = 1   '日付行番号
    Const DateCol As Long = 4   '日付開始列 D
    Const TypeNos As Long = 3   '形態（A,B,C等)数
    Const qtyRow As Long = 24    '個数開始行
    Const PRow As Long = 4      '個人別入力開始行

    Dim PBlocks As Variant
    Dim PLines As Long
    Dim QtyLines As Long
    Dim mealV() As Long

 Private Sub Workbook_Open()
    Dim i As Long
    Dim x As Long
    PBlocks = Array(5, 2)       '個人別欄の昼食用人数,夕食用人数　夜食ができれば Array(5,2,4) とか
    QtyLines = UBound(PBlocks) + 1
    PLines = WorksheetFunction.Sum(PBlocks)
    ReDim mealV(UBound(PBlocks))
    x = PRow
    For i = LBound(mealV) To UBound(mealV)
        mealV(i) = x
        x = x + PBlocks(i)
    Next
 End Sub

 Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

    Dim x As Long
    Dim c As Range
    Dim z As Long
    Dim cnt As Long

    If Not Sh Is Sheets("週間表") Then Exit Sub

    Cancel = True
    x = Cells(DateRow, Columns.Count).End(xlToLeft).Column
    Set c = Intersect(Target, Range(Cells(PRow, DateCol), Cells(PRow, x + TypeNos - 1)).Resize(PLines))

    If c Is Nothing Then Exit Sub
    Application.EnableEvents = False
    c.Value = IIf(c.Value = "○", "", "○")
    Application.EnableEvents = True
    z = WorksheetFunction.Match(c.Row, mealV)
    cnt = WorksheetFunction.CountIf(Sh.Cells(mealV(z - 1), c.Column).Resize(PBlocks(z - 1)), "○")
    Sh.Cells(qtyRow, c.Column).Offset(z - 1).Value = cnt

 End Sub

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    Dim x As Long
    Dim c As Range
    Dim tRow As Long
    Dim abc As Long
    Dim mm As Long
    Dim dd As Long
    Dim wd As String

    If Not Sh Is Sheets("週間表") Then Exit Sub

    x = Cells(DateRow, Columns.Count).End(xlToLeft).Column
    Set c = Intersect(Target, Range(Cells(qtyRow, DateCol), Cells(qtyRow, x + TypeNos - 1)).Resize(QtyLines))

    If c Is Nothing Then Exit Sub

    If c.Count > 1 Then
        MsgBox "数値変更は、単一セルだけにしてください" & vbLf & "入力を取り消します"
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
        Exit Sub
    End If
    abc = (c.Column - DateCol) Mod TypeNos
    x = ((c.Column - DateCol) \ TypeNos) * TypeNos + DateCol
    mm = Month(Cells(DateRow, x).Value)
    dd = Day(Cells(DateRow, x).Value)
    wd = Format(Cells(DateRow, x).Value, "aaa")

    With Sheets("変更届")
        tRow = getRow(mm, dd)
        If c.Value <> Sheets("変更前").Range(c.Address).Value Then
            .Cells(tRow, "D").Offset(, 2 * TypeNos * (c.Row - qtyRow) + abc * 2 + 1).Value = c.Value
            .Cells(tRow, "D").Offset(, 2 * TypeNos * (c.Row - qtyRow) + abc * 2).Value = Sheets("変更前").Range(c.Address).Value
            .Cells(tRow, "A").Value = mm
            .Cells(tRow, "B").Value = dd
            .Cells(tRow, "C").Value = wd
        Else
            .Cells(tRow, "D").Offset(, 2 * TypeNos * (c.Row - qtyRow) + abc * 2).Resize(, 2).ClearContents
        End If

        With .Rows(tRow)
            If WorksheetFunction.Count(.Range("D1").Resize(, TypeNos * 2 * QtyLines)) = 0 Then .Delete
        End With
    End With

 End Sub

 Private Function getRow(mm As Long, dd As Long) As Long
    Dim x As Long
    Dim i As Long

    With Sheets("変更届")

        x = .Range("A" & .Rows.Count).End(xlUp).Row
        If x < 3 Then
            x = 3
        Else
            For i = 3 To x
                If .Cells(i, "A").Value = mm And .Cells(i, "B").Value = dd Then
                    x = i
                    Exit For
                End If
            Next
            x = i
        End If

        getRow = x

    End With

 End Function

 (ぶらっと)

 追加で

 作業用などで用意したSetEventは、１つのプロシジャでトグル的にステータスを繰り返し変更していくわけだけど
 現在のステータスが何なのか、処理結果、どうなったのか、ちょっと不安になるかもしれない。
 なので、以下のように、実行結果、ステータスはどうなったのかを表示するようにしておこう。

 Sub SetEvent()
    Application.EnableEvents = Not Application.EnableEvents
    MsgBox IIf(Application.EnableEvents, "イベント発生を再開しました", "イベント発生を停止しました")
 End Sub

 (ぶらっと)

 早くから作って頂いていたのに、ネットできる環境におらず遅くなりました。すみません。
 ロンドン。テンション上がりますね～☆ミ

 早速ですが、、
 Set c = Intersect(Target, Range(Cells(PRow, DateCol), Cells(PRow, x + TypeNos - 1)).Resize(PLines))
 でエラーが出てしまいました。。

 エラーメッセージは、どういうものだった？
 また、上でコメントしている、週間表シートの１週間分のデータ準備。これを１）～５）まで正しく実行した後
 ６）以降の操作でエラーになったということだね？
 で、エラーで止まった時の、このコードの、PRowやDateColやTypeNosやPLinesにマウスを当てて、浮かび上がった値を教ええてくれる？

 それと、最新にアップしたコードは、

 週間表シートの合計欄は、24行目と25行目。
 個人の欄は仮に、Const PRow As Long = 4      '個人別入力開始行
 また、そこに記載されている個人データは昼食用が5人、夕食用が2人。PBlocks = Array(5, 2)　で規定。

 これは大丈夫かな？

 かつ、シートモジュールに書かれている古いコードは消したうえで、ThisWorkbookモジュールにアップしたコードを書いてくれているよね？

 よく見ると、
 Set c = Intersect(Target, Range(Cells(PRow, DateCol), Cells(PRow, x + TypeNos - 1)).Resize(PLines))

 このコード自体、ちょっと手抜きだったんだけど、通常の操作をする限り、エラーにはならないと思っている。

 (ぶらっと)

 ぶらっとさん、できましたー！！！すごいです。
 イメージしていたものができて、かなり感動です..(T-T)

 PBlocks = Array(5, 2)の規定で、行が合っていませんでした。。

 こんな初心者丸出しの私にも、ご丁寧に教えて頂き、本当にありがとうございますm(_ _)m
 これを機に、少しずつ勉強していきたいと思います。

 感謝でいっぱいです(>_<)
 長い間お付き合い頂き、本当にありがとうございました！
 またよろしくお願いしますm(_ _)m

（UMI）

コメント返信：

[ 一覧(最新更新順) ]

[[20120731144914]] 『変更前・変更後のデータを別シートへ』（UMI） ページの最後に飛ぶ

[[20120731144914]]　『変更前・変更後のデータを別シートへ』（UMI）　ページの最後に飛ぶ