[[20150325231051]] 『B1に入力するとA1に連番999の次は1』(もんぺ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『B1に入力するとA1に連番999の次は1』(もんぺ)

マクロ初心者です
先人が書いたマクロのセルの部分を書き換えて使っている程度です
お教えください
B1に入力するとA1に自動で連番をだしたいです。
条件がいくつかあり悩んでいます。
workbookに1か月分(31日分)のsheetをつくっています。1つのsheetに対し、B列に1日で約100ほどの
入力をしています。

   A   B             A   B ・・・    A   B
1: 1  あ         1:                 1: 998  く
2: 2  い         2: 4   え          2: 999  け
3: 3  う         3: 5   お          3: 1    こ 
4:               4: 6   か          4:
・                ・                 ・
・                ・                 ・
・                ・                 ・
100:            100:997 き        100:
sheet1           sheet2    ・・・   sheet31

条件1
sheet1 B列に入力後、sheet2B列に新たに入力する場合、A列にはsheet1A列の最後(A3)の数字のつづきから連番にしたい
※sheet2以降、前のsheet(左隣のsheet)のA列の最後の数字のつづき
条件2
各sheetのB列への入力開始はB1からとは限らない。
B1:B100の任意のセルから入力開始したい
条件3
A列の数字が999になったら次の数字は1から始まるようにしたい(ゼロは使わない)
条件4
入力後、後から以前入力したA列とB列の特定のセルの文字をDeleteで消しても、以降のA列の連番は変化させたくない(繰り上がりさせたくない)
例:sheet1最後の のA3とB3の「3」と「う」を消してもsheet2以降の A2:B2「4」と「え」はそのまま※「5」「え」とならない
  ※後から消したところはぬけたままでよい(1、2、4、5・・・)でよい 
このような条件で、どのようにしたらよいかどなたかお教えねがいます。 

< 使用 Excel:Excel2010、使用 OS:Windows7 >


 説明があったもの以外に、条件を明確にしておいたほうがいいところがありそうです。

 たとえば

 1.入力をする場合に、開始行は1からとは限らないということはいいのですが
  たとえば 4行目にいれた。次は、6行目に入れる。つまり、入力そのものをとびとびで
  行っていいのですか? とびとびはだめなんですか?
 (とびとびOKじゃないと、他の条件と不整合になるので、行っていいんでしょうね?)

 2.Sheet1 で B列に10個の値をいれたとします。連番は 1〜10 割り振り済みですね。
  次に Sheet2 の B列に値をいれました。Sheet2 に連番としては 11 から採番されますね。
  この後、Sheet1 の B列に入力をしていないものがあったことに気が付きました。
  で、すでに入力済みの10個の下に、何か値をいれました。
  Sheet1 としては 連番は 11 でしょうけど、11 はすでに、Sheet2 で割り振り済みですね。
  この場合、どうしますか? 
  入力禁止? でも、それは、入力忘れで、絶対に入力しなきゃいけないものだった場合は?

 3.「セルの文字をDeleteで消しても、以降のA列の連番は変化させたくない(繰り上がりさせたくない) 」
  この場合は、「繰り下がる」ことになるので、説明文のミスだと思いますが、いずれにしても割り振り済みの番号は
  変えないというルールですよね。
  Sheet1 で、以下のケースはどうなりますか?

   1)B1〜B10 に入力した。A1〜A10 は 1〜10 になった。
   2)このあと 1行目〜5行目を空白にした。6行目以降は 6〜 のままですね。
   3)で、消しすぎた。B3 は消してはいけなかったということに気が付きました。
   4)そこで、B3 に値を入れるのですが、ここでセットすべき連番はいくつでしょう?
    Sheet1 の最初の値ですから 1 ?
    それとも、Sheet1 のそのあとが 6 だから 5 ?
    でも、もともと、このB3 に対しては 3 が割り振られていて、それをかえてはいけないのに
    うっかりと消してしまったとすれば、 3 に戻すべき?

 4.この操作(業務)の要件として、割り振り済みのものを消した場合に、
  1)うっかりミスで入力してはいけないのに入力したものを消した。
  2)入力すべきものだったので、そこで割り振られた番号は【正規番号】、だから、消されても残るべき。
   
   こういう考え方があるなら、両者の区別はどうするか?

 こういったことも加味して、(まだまだあるかもしれません)今考えている条件が、それだけで十分かどうか
 (特に、入力ミス、操作ミスも含めた運用面を考えて)整理されてはいかがですか?
 条件によっては、どこかに、割り振り済みの番号をセットしておく隠し領域も必要かもしれませんし。

(β) 2015/03/26(木) 05:59


 追加で

 本件、コードとしての条件や、そのディスカッションの前に、このマクロを使って対応する【業務】そのものを
 説明されてはいかがですか?

 たとえば、毎月、ある申請書がだされる。この時に、申請書番号をわりふる。
 割り振られた人からみれば、それが 10 番なら、ずっと10番。以降の様々な手続きで、申請書番号が必要になれば
 「10番です」と、こうなりますね。

 たとえ、なんらかの理由で、 6 番の申請が取り消されたとしても、10 番の申請書は 10 番ですね。
 かってに、 9 番になると困りますからね。

 だけど、こういった業務の場合、それを「入力操作」という面からみれば、うっかり入力、重複入力、入力忘れ。
 こういったことも考慮しなければいけませんよね。

 そうした場合、これをマクロではなく台帳で管理していたとして、正規に受け付けた申請の、その取り消しと
 入力間違いによる、後追い入力や取り消し、これらをどう区別して、どう扱うか。 (どんな業務ルールとするか)
 先月の申請忘れの場合は、どうするか。

 手作業管理ベースで、ルール・手順を明確にしてみることも必要ではないでしょうか?

(β) 2015/03/26(木) 06:59


元が追加されたら、以降全て番号を変える、というのは現実的ではないと思いますが、とりあえず1つ上の値に1足していく例なぞ。

A2セル =MOD(A1,999)+1
(???) 2015/03/26(木) 10:25


 >後から以前入力したA列とB列の特定のセルの文字をDeleteで消しても、以降のA列の連番は変化させたくない

 ですから、確定した番号はかえちゃいけないみたいですよ。

(β) 2015/03/26(木) 11:17


βさま、丁寧なご対応感謝いたします。
また(???)さまご返答ありがとうございます。

はじめに、βさまとは、以前このサイトで何度かやりとりをいたしました。名前は「さだ」だったと思います。その節はありがとうございました。
その際の内容を継続していけばこのようにお手間をとらせないですんだものを、何度も追加で聞きたいことがあり、それを恥ずかしくおもい、ちがう
名前でおたずねしましたことをまた恥じる次第です。申し訳ありませんでした。

業務についてご説明するまえに、以前Mookさまからご教示いただいた以下のマクロでラベルを発行しようと下記のマクロをかいていただきました。

Private Sub Worksheet_Change(ByVal Target As Range)

    Const データ範囲 = "F7:H10"
    If Intersect(Target, Range(データ範囲)) Is Nothing Then Exit Sub
    Dim 対象セル As Range
    For Each 対象セル In Intersect(Target, Range(データ範囲))
        If 対象セル.Value <> "" Then  '// データがない時は(削除したときも)印刷しない
            Application.EnableEvents = False
            Range("B1").Value = Cells(対象セル.Row, "C").Value
            Range("B2").Value = Cells(対象セル.Row, "D").Value
            Range("B3").Value = Cells(対象セル.Row, "E").Value
            Range("B4").Value = Cells(6, 対象セル.Column).Value
            Range("B5").Value = 対象セル.Value
            Application.EnableEvents = True
            If Application.CountBlank(Range("B1:B5")) = 0 Then
                If MsgBox("印刷を実行しますか?", vbYesNo) = vbYes Then ActiveSheet.PrintOut
            Else
                If MsgBox("空欄があります。印刷を実行しますか?", vbYesNo) Then ActiveSheet.PrintOut
            End If
        End If
    Next
 End Sub

βさまはおわかりになるかと思いますが、質問者の私が説明するのに混乱していますのでセルの場所を整理しまして下記のマクロでご説明させて
いただきたいと思います。
下記のマクロは、上記のマクロに、入力した時間が入るマクロを追加して印刷をおこなうところまで書いていただきました。連番の問題以外はこれで目的は果たせております。
Private Sub Worksheet_Change(ByVal Target As Range)

    Const データ範囲 = "F5:F200"
    If Not Intersect(Target, Range(データ範囲)) Is Nothing Then
    Dim 対象セル As Range
    For Each 対象セル In Intersect(Target, Range(データ範囲))
        If 対象セル.Value <> "" Then  '// データがない時は(削除したときも)印刷しない
            Application.EnableEvents = False
            Range("B1").Value = Cells(対象セル.Row, "C").Value
            Range("B2").Value = Cells(対象セル.Row, "E").Value
            Range("B3").Value = Cells(対象セル.Row, "G").Value

            Application.EnableEvents = True
        If Application.CountBlank(Range("B1")) + Application.CountBlank(Range("B2")) + Application.CountBlank(Range("B3")) = 0 Then

                If MsgBox("印刷を実行しますか?", vbYesNo) = vbYes Then ActiveSheet.PrintOut
            Else
                 MsgBox ("空欄があります。確認してください。")
            End If
        End If
    Next

 End If

If Target.Count <> 1 Then Exit Sub

  If Target.Column = 5 Then
     If Target.Value <> "" Then
        Target.Offset(0, 2) = Now

     End If

  End If
 End Sub

入力欄はD5:F100です。D列には空箱のおもさ、E列には空箱に商品を入れたときのおもさ、F列には入力した人の人名コードを入力します。
C、E、Gと左から右に順番に入力していきGに入力したときのA1:B3のラベルがでるようなしくみを作ろうと思っています。

     A          B         C   D     E      F     G         A           B         
1:シリアルN.o. / 2                             1:シリアルN.o  /  4
2:重さ         / 13kg                                    2:重さ         / 10kg
3:時間         / 8:15                                    3:時間         / 9:00
4:                           空箱/ 重さ / 人名/ 時間   
5:                        1/ 1kg / 12kg /  10 / 8:03      
6:             2/ 1kg / 13kg /  18 / 8:15
7:                        3/ 2kg
・
100
                        sheet1・・・・・・・・・・・・・・・・・・sheet2

さて、業務について話をもどしますが、ラベルを一つの商品に対して1枚貼ります。1箱はみかん箱程度の大きさで、24箱(24枚)で1パレット
として顧客に出荷いたします。999までのシリアルN.o.は顧客側の要望で、その理由は、顧客の倉庫には最大でも20パレット(約480箱)までしか
置けないのでシリアルN.oは999までで足りるということです。、※顧客側はいつもは倉庫には10パレット(240箱)程度をもち、先入れ先出しで出荷して
います。
私たちは、シリアルN.o.を1〜999まで重複しないようにつけるよう依頼されています。その際は、重複しなければ順不同でかまいません。また、ラベルを張る前に
ラベルをなくしたり、やぶいたりしても再発行はせず999の中に抜けた番号があっても重複さえしなければOKです。現在は、A4用紙に10個のマス(ラベル)を
書いて、1枚目は1マス目に2マス目に2番・・・10番までを連番でふり、2枚目には11〜20をふり、3枚・・・100枚印刷し、裁断機で10分割し、使用しています。
(今回、入力したら重さや時間が印刷されればと思っているそれぞれの項目ももちろん手書きでやっております。・・・原始的)
ラベルのルール
ルール1
ラベルを使いきるまで新たに切り出したラベルを混ぜて使わない
ルール2
ラベルを切り出し束ねる際には、番号の若い順から重ねる
ルール3
ラベルを張る際には、束ねられたラベルの上(若い番号)から使う
ルール備考
ラベルを張る前に、ちぎれたり、数枚なくした場合でもそのまま次のラベルをつかってよい(番号はとばしてよい)
これらのルールで番号を重複することを防いでいます。

この要件を満たしたくお願いした次第です。
Deleteで消しても・・・についてですが
・消してしまうおそれがあるのは作業中のセル付近です。何日も前のものをけしたりすることはありません
・消してしまった場合はシリアルN.o.の入力箇所に重複しない適当な番号を手入力したい
 ※ラベルを無くした(ちぎれた)場合に今やっているような対応をエクセルでしたい
最後に月が切り替わるときについてですが
エクセルファイルがかわるので、月初めの最初の入力だけ先月の最後の番号をみてその数字に1を足した数字を手で入力
そのつぎからはその数字を参照して連番・・・のようなやり方がいいのか?
このような感じです。簡単そうでかなり複雑なことにきづきました
なんとか同僚が楽になればというねがいをかなえたいと思っております
よろしくお願いいたします。


訂正です

誤り
現在は、A4用紙に10個のマス(ラベル)を書いて、1枚目は1マス目に2マス目に2番・・・10番までを
訂正
現在は、A4用紙に10個のマス(ラベル)を書いて、1マス目に1番に2マス目に2番・・・10番までを

A4用紙を10分割したラベルのイメージは項目とシリアルN.o.の番号のみ印刷されています

        1/10                    2/10 ・・・・・・・・・10/10
シリアルN.o./ 1           シリアルN.o./ 2         リアルN.o. / 10・・・999
重さ    /                重さ     /             重さ     /  
時間    /                時間     /             時間     /

よろしくお願いします。
(もんぺ) 2015/03/27(金) 01:31


 説明ありがとうございます。まだ細かなところまで読んでいませんが、業務については、なんとなく把握できました。
 私自身、一時期、倉庫管理の現場のアドバイザーのような役割を担っていたことがあり、
 顧客それぞれの「勝手な?」要望に、きりきりまいをさせられたことを懐かしく思い出しています。

 さて、要件はこれからじっくり読ませていただきますが、

 >何度も追加で聞きたいことがあり、それを恥ずかしくおもい、ちがう名前でおたずねしましたことをまた恥じる次第です

 追加質問そのものは、恥じる必要はまったくありません。むしろ、前トピの継続ということで質問を投げかけられれば
 回答側にとって、要件なども、前スレも参考にしながら、理解が進むと思います。

 その際には

[[20150310182705]] 『アクティブセルを参照し、かつその隣のセルも参照』(さだ)

 といったようにリンクも張っておけばわかりやすいです。

 さらにいえば、前スレで、継続して質問を投げかけることがよろしかったと思いますよ。
 Mookさんの回答やコメントに対して、レスなしで終わっていて、そのことで気が引けたのかもしれませんが。
 これはこれで、あまり感心しませんね。ましてや、Mookさんの提供コードで運用実現しているのですから
 今からでも、前スレのMookさんの回答、アドバイスにレスしておかれるべきですね。

 いずれにしても、今回もMookさんから継続してお手伝いもあるかと思いますが、邪魔にならない程度に私も考えてみます。

(β) 2015/03/27(金) 06:49


 まだ、読み切っていません。

 その前に、

 アップされたコードですが、当初の Mookさんに提示いただいたコードに、「見覚えのある」部分が
 追加されてますね。別スレで、質問1,2,3でβが答えた件だったんですね。

 で、あの時は、詳細は見ていなくて、大筋で、コードの組み立てを申し上げたのですが

 Application.EnableEvents の場所が適切ではありません。
 結果的には、障害は発生しませんが、無駄なイベントが連鎖しています。

 最後の部分、以下のようにしておかれたらいいですよ。
 (最初のブロックも一緒に、ひとまとめにしてもいいのですが、そうすると、コードをだいぶ直さなきゃいけないので)

    If Target.Count <> 1 Then Exit Sub

    Application.EnableEvents = False

    If Target.Column = 5 Then
        If Target.Value <> "" Then
            Target.Offset(0, 2) = Now
        End If
    End If

    Application.EnableEvents = True

 End Sub

 で、もう1つ。飛び飛びの領域だったので COUNTBLANK を分けましたけど
 今回アップされたものでは B1:B3 で、連続領域ですよね。
 であれば、分ける必要はありませんよ?

(β) 2015/03/27(金) 22:16


ご返答ありがとうございます。

今回のやりとりでとびとびの領域と連続の領域のふたつのパターンをおぼえました
入力するラベルのレイアウトはたまに変更されるので両方のパターンがあることを知れたので
たすかりました。
さっそくやってみます
(もんぺ) 2015/03/27(金) 23:56


 まだ、コードは書いていませんが、以下のような組み立てにしようと考えています。
 (もんぺ)さんの目で見て、ここはちょっと具合が悪いなと思うところあれば遠慮なく指摘願います。

 1.まず、シート名ですが、必ず固定の●●●(たとえば"ラベル管理" とか)に、半角1,2,3,・・,11,12 をつけたものとしてください。

 2.1月の入力の場合、前年12月末の最後のカウンタを参照する必要がありますが、前年ブックを読みに行く仕様だと
  ブック名等に制約が出ること、それよりも、裏の処理がもったいないということもあり、
  今年のこのブックに隠しシートを設け、そのたとえばA1に、前年の最後のカウンタ数値を記述しておいてください。
  1月の入力では、この値を参照します。隠しシートは、もちろん、非表示でOKです。

 3.入力欄は B1:B100 のみとします。(A1:A100 は触れない。もし触られれば強制的に元に戻します。)
  これは、コードで対応しますが、入力時のうっかりミスを防ぐため、
  B1:B100 を選択、書式で保護タブ、ロックのチェックを外したうえで、シート保護。
  シート保護時は、保護されたセルの選択のチェックをはずして保護を掛けてください。
  こうしておけば、B1:B100 いがいにカーソルはいかないようになります。

 4.連番設定の制御は以下を考えています。

  1)B列が空白で取り消されたら、A列の番号も空白にします。
  2)その月の最初(一番上)の入力であれば、前の月の最終の番号 + 1 にします。
  3)その月の最初の入力ではなかったら、取得された連番が、その1つ上の番号より大きくなければエラー。(入力を禁止。強制的に元戻し)
  4)その下に、すでにその月の別のものがあれば、取得された連番が、その番号より小さくなければエラー。(入力を禁止。強制的に元戻し)
  5)その月の最後の(一番下)の入力の場合、4)のチェックを、翌月シートの最初の番号(があれば)と比較します。
  6)12月については、5)ができないので、もし、先行して、翌年の採番が行われていたとしてもチェックはしません。
   ここは運用で十分に注意をしてください。

 大きい、小さい という表現を使っていますが、もちろん、999 での 1 への折り返しは対応します。

(β) 2015/03/28(土) 07:55


(β)さまご返答ありがとうございます
1)OKです
2)OKです
3)4)"重複しない"と"連番"と"順不同"と"ぬけがあってもよい"の条件を"大きくなければ""小さくなければ"で対応・・・・すごいです
5)(があれば)すごいです。そうしたかったです
6)丁寧にありがとうございます
まだ実際はわかりませんが、条件として満足しております。
機械(コンピュータ)の考え方と人間の考え方両方をわからなければ日本語の条件はかけないのですね
さきが見えてきた気がします。ありがとうございます。

(もんぺ) 2015/03/28(土) 09:38


 15:11 追記

 重大な誤解をしていました。月ではなく日だったんですね!
 ロジックはほとんど同じですが、以下のコードは シート1枚を月と想定しています。
 とりあえず、12枚のシートでお試しください。
 最終版は後ほど。

 ・・・・・・・・・・・・・・・

 簡単な動作確認はしましたが、実際の運用、操作者の操作のバリエーションによっては落とし穴があるかもしれませんので
 十分に確認をしてみてください。

 なお、月またがりのチェック、昨年12月から今年の1月、今年の12月から翌年の1月については前にコメントした通りですが
 通常月の場合、前月に何も動きがない、あるいは翌月に何もうごきがない場合、理屈としては前々月、あるいは翌々月のチェックを
 すべきでしょうが、先月と翌月のみのチェックにしています。実務としては問題ないとは思いますが。

 それと、一度に複数セルへの入力は禁止しました。(ロジックが入り組みすぎるので)
 なので、Deleteキーによる空白化も含め、入力は、単一セルでお願いします。

 コード中、★がついたところは、実際のそちらの実態にあわせて変更してくいださい。
 コードでは、入力域が "B1:B100"、シート名は、面倒だったので、"Sheet1"、"Sheet2"、・・・"Sheet12" にしてあります。
 ★の Const PRENM As String = "Sheet"         '★シート名プリフィックス のところです。
 また、前年の最終値、コードでは、"work" という名前のシートの A1 にしています。
 preVal = Worksheets("work").Range("A1").Value      '★隠しシートのA1の値
 この部分です。

 ThisWorkbookモジュールに書きます。(VBE画面の左上、プロジェクトエクスプローラのツリーのThisWorkbookをダブルクリック)

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Const PRENM As String = "Sheet"         '★シート名プリフィックス
    Const INPAREA As String = "B1:B100"     '★入力対象領域
    Dim nm As Long
    Dim c As Range
    Dim f As Range
    Dim ng As Boolean
    Dim uCell As Range
    Dim dCell As Range
    Dim tmpVal As Long
    Dim preVal As Long
    Dim nxtVal As Long
    Dim inpCnt As Long

    If Left(Sh.Name, Len(PRENM)) <> PRENM Then Exit Sub         '月シートのみ処理

    If Not Intersect(Target, Sh.Range(INPAREA).Offset(, -1)) Is Nothing Then    '採番領域の変更
        MsgBox "採番セルの変更は禁止されています" & vbLf & "入力を取り消します"
        Application.EnableEvents = False    'イベント連鎖の抑止
        Application.Undo                    '入力を元に戻す
        Application.EnableEvents = True     'イベント発生再開
        Exit Sub
    End If

    Set c = Intersect(Target, Sh.Range(INPAREA))    '入力領域と対象領域の重なり

    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

    nm = Val(Replace(Sh.Name, PRENM, ""))                   '月を数値で把握
    inpCnt = Range(INPAREA).Cells.Count                     '入力域のセル数

    Application.EnableEvents = False            'イベント発生抑止

    '前月の最終番号を取得
    If nm = 1 Then  '今月が1月なら
        preVal = Worksheets("work").Range("A1").Value      '★隠しシートのA1の値
    Else
        With Worksheets(PRENM & nm - 1)
            Set f = .Range(INPAREA).Find(What:="*", LookAt:=xlWhole, SearchDirection:=xlPrevious)
            If f Is Nothing Then
                preVal = 0  '先月の動きがない場合やむなし
            Else
                preVal = f.Offset(, -1).Value
            End If
        End With
    End If

    If preVal = 999 Then preVal = 0

    '次月の最初の番号を取得
    If nm = 12 Then
        nxtVal = 1000      '12月なら翌年の数値は、かりにあってもチェックしない。
    Else
        With Worksheets(PRENM & nm + 1)
            Set f = .Range(INPAREA).Find(What:="*", LookAt:=xlWhole, After:=.Range(INPAREA).Cells(inpCnt))
            If f Is Nothing Then    '翌月はまだ入力前
                nxtVal = 1000
            Else
                nxtVal = f.Offset(, 1).Value
            End If
        End With
    End If

    If IsEmpty(c) Then                  '空白での取り消しなら当該採番をクリア
        c.Offset(, -1).ClearContents
    Else
        If WorksheetFunction.CountA(Sh.Range(INPAREA)) = 1 Then '今月唯一の入力
            tmpVal = IIf(preVal = 999, 1, preVal + 1)
            If tmpVal >= nxtVal Then ng = True
        Else
            'この上の入力セル
            Set uCell = Sh.Range(Sh.Range(INPAREA).Cells(1), c).Find(What:="*", LookAt:=xlWhole, SearchDirection:=xlPrevious, After:=c)
            'この下の入力セル
            Set dCell = Sh.Range(c, Sh.Range(INPAREA).Cells(inpCnt)).Find(What:="*", LookAt:=xlWhole, After:=c)

            If uCell.Address <> c.Address Then          '上にある
                If dCell.Address <> c.Address Then      '上にも下にもある
                    tmpVal = IIf(uCell.Offset(, -1).Value = 999, 1, uCell.Offset(, -1).Value + 1)
                    If tmpVal >= dCell.Offset(, -1).Value Then ng = True
                Else                                    '上にだけある
                    tmpVal = IIf(uCell.Offset(, -1).Value = 999, 1, uCell.Offset(, -1).Value + 1)
                    If tmpVal >= nxtVal Then ng = True
                End If
            Else                                        '下のみにある
                tmpVal = IIf(preVal = 999, 1, preVal + 1)
                If tmpVal >= dCell.Offset(, -1).Value Then ng = True
            End If
        End If

        If ng Then
            MsgBox "この場所ではラベル番号の採番はできません" & vbLf & "入力を取り消します"
            Application.Undo                            '入力を元に戻す
        Else
            c.Offset(, -1).Value = tmpVal '採番領域に結果をセット
        End If

    End If

    Application.EnableEvents = True         'イベント発生再開

 End Sub

(β) 2015/03/28(土) 14:58


 日別シート版になおすにあたり。

 1.月により最終日が異なりますね。シート31が最終日なのか、シート28が最終日なのか。
   で、隠しシートの A2 に、このブックの月を日付型で持ちましょう。
   2015/3 といったように入力しておいてください。

 2.気になることがあります。

 月別の場合は前月に動きがない、翌月に動きがないということはありえないと思いますが、日別の場合は
 倉庫休日のケースもあるでしょうし、たまたまラベル発行業務を行わなかった日もあると思います。
 たとえば昨日、発行がなかった。つまり昨日のシートはからっぽ。
 一昨日 400 番まで採番していても、コードは昨日のシートのみをチェックして、あぁ、これは 1 からの採番だと。

 これは具合が悪いですね? いや、毎日、必ず業務は行われるということならいいのですが・・・?
 いかがでしょうか?

(β) 2015/03/28(土) 15:48


 なんとかできたような気がします。お試しください。
 先にコメントした通り、当月がいつなのかを隠しシートのA2 に 2015/3 といった形で入れておいてください。
 前日からさかのぼって動きのある直近の日の最終番号と、翌日から先行き、動きのあった直近の日の最初の番号を参照します。

 B列入力で採番、あるいはエラーメッセージ、空白にすれば、A列の採番も消します。

 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Const PRENM As String = "Sheet"         '★シート名プリフィックス
    Const INPAREA As String = "B1:B100"     '★入力対象領域
    Dim nm As Long
    Dim c As Range
    Dim f As Range
    Dim ng As Boolean
    Dim uCell As Range
    Dim dCell As Range
    Dim tmpVal As Long
    Dim preVal As Long
    Dim nxtVal As Long
    Dim inpCnt As Long
    Dim eod As Long
    Dim yymm
    Dim wSh As Worksheet
    Dim x As Long

    If Left(Sh.Name, Len(PRENM)) <> PRENM Then Exit Sub         '日シートのみ処理

    Set wSh = Sheets("work")                                '★隠しシート
    nm = Val(Replace(Sh.Name, PRENM, ""))                   '日を数値で把握
    inpCnt = Range(INPAREA).Cells.Count                     '入力域のセル数
    yymm = wSh.Range("A2")                                  '★隠しシートの今月の日付
    eod = Day(DateSerial(Year(yymm), Month(yymm) + 1, 0))   '今月の最終日

    If nm > eod Then Exit Sub                               '今月の日付以外のシートなら処理しない

    If Not Intersect(Target, Sh.Range(INPAREA).Offset(, -1)) Is Nothing Then    '採番領域の変更
        MsgBox "採番セルの変更は禁止されています" & vbLf & "入力を取り消します"
        Application.EnableEvents = False    'イベント連鎖の抑止
        Application.Undo                    '入力を元に戻す
        Application.EnableEvents = True     'イベント発生再開
        Exit Sub
    End If

    Set c = Intersect(Target, Sh.Range(INPAREA))    '入力領域と対象領域の重なり

    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

    Application.EnableEvents = False            'イベント発生抑止

    If IsEmpty(c) Then                  '空白での取り消しなら当該採番をクリア
         c.Offset(, -1).ClearContents
    Else
        '前日以前で動きのあった直近の日の最終番号を取得
        If nm > 1 Then
            For x = nm - 1 To 1 Step -1
                If WorksheetFunction.CountA(Worksheets(PRENM & x).Range(INPAREA)) > 0 Then
                    With Worksheets(PRENM & x)
                        preVal = .Range(INPAREA).Find(What:="*", LookAt:=xlWhole, SearchDirection:=xlPrevious).Offset(, -1).Value
                    End With
                    Exit For
                End If
            Next
        End If

        If preVal = 0 Then preVal = wSh.Range("A1").Value       '★隠しシートのA1の値
        If preVal = 999 Then preVal = 0

        '翌日以降で動きのあった直近の日の最初の番号を取得
        If nm < eod Then
            For x = nm + 1 To eod
                If WorksheetFunction.CountA(Worksheets(PRENM & x).Range(INPAREA)) > 0 Then
                    With Worksheets(PRENM & x)
                        nxtVal = .Range(INPAREA).Find(What:="*", LookAt:=xlWhole, After:=.Range(INPAREA).Cells(inpCnt)).Offset(, 1).Value
                    End With
                    Exit For
                End If
            Next
        End If

        If nxtVal = 0 Then nxtVal = 1000

        If WorksheetFunction.CountA(Sh.Range(INPAREA)) = 1 Then '今日唯一の入力
            tmpVal = IIf(preVal = 999, 1, preVal + 1)
            If tmpVal >= nxtVal Then ng = True
        Else
            'この上の入力セル
            Set uCell = Sh.Range(Sh.Range(INPAREA).Cells(1), c).Find(What:="*", LookAt:=xlWhole, SearchDirection:=xlPrevious, After:=c)
            'この下の入力セル
            Set dCell = Sh.Range(c, Sh.Range(INPAREA).Cells(inpCnt)).Find(What:="*", LookAt:=xlWhole, After:=c)

            If uCell.Address <> c.Address Then          '上にある
                If dCell.Address <> c.Address Then      '上にも下にもある
                    tmpVal = IIf(uCell.Offset(, -1).Value = 999, 1, uCell.Offset(, -1).Value + 1)
                    If tmpVal >= dCell.Offset(, -1).Value Then ng = True
                Else                                    '上にだけある
                    tmpVal = IIf(uCell.Offset(, -1).Value = 999, 1, uCell.Offset(, -1).Value + 1)
                    If tmpVal >= nxtVal Then ng = True
                End If
            Else                                        '下のみにある
                tmpVal = IIf(preVal = 999, 1, preVal + 1)
                If tmpVal >= dCell.Offset(, -1).Value Then ng = True
            End If
        End If

        If ng Then
            MsgBox "この場所ではラベル番号の採番はできません" & vbLf & "入力を取り消します"
            Application.Undo                            '入力を元に戻す
        Else
            c.Offset(, -1).Value = tmpVal '採番領域に結果をセット
        End If

    End If

    Application.EnableEvents = True         'イベント発生再開

 End Sub

(β) 2015/03/28(土) 17:33


・・・こんなことになるとは・・・
(β)さんへ感謝のきもちが言葉でみつからないほどです
そして(β)さんこわいぐらいすごい
それと前スレで「さきが見えてきた気がします。ありがとうございます。」といってしまったこと
とんでもない誤解でした。お詫びと撤回いたします。
わたしも12か月と31日のことわすれていました。31日バージョンありがとうございます。
やってみます。のちほどご連絡iご連絡いたします。
とにかくご尽力していただいたこと重ね重ねありがとうございます。

(もんぺ) 2015/03/29(日) 10:14


(β)さまおせわになっております。
ただいま検証中です
少し時間がかかりそうですが(β)さまのご尽力に報いるべく奮闘しております。
ご質問におこたえしてないところがありました。申し訳ありません
(β) 2015/03/28(土) 15:48
「2.気になることがあります。」について
ですが、すでに対策していただいてありがとうございました。
おっしゃるとおり、日別でシートを作成します。定休日もありますし、製品の種類によってbookも変わります。
ですので前日のシート(または数日間)が空っぽのときもあります。
加味していただきありがとうございます。(私より私の仕事を熟知している・・・泣)

(もんぺ) 2015/03/29(日) 23:27


 はい。検証よろしく。
 Bookが変わった時の、前のBookの最終番号は隠しシートのA1にいれておくことで対処していますが
 翌月ブックの値の参照は、コメントしたように手を抜いて割愛しています。

 たとえば、3月が 800 で終わった。で、4月のラベル発行が4月ブックで行われ、 801が採番されていた。
 この後、3月で1枚忘れていたことに気が付いて、追加した。
 翌月ブックの参照はしていないので【平気】で、801が採番されてしまう。

 ここは【エラー】として、この状態では採番できないようにしなければ だれも気が付かないまま801 が重複しますね。

 この制御は、隠しシートの たとえば B1 に、翌月の最初の採番結果をいれておいてもらうことで
 それを参照することは可能ですので、 もし、必要ならいってください。

 ただ、そうすると、必ず、翌月ブックの最初の採番結果を前月ブックにいれておかなければいけないという
 運用面でのわずらわしさも増幅しますので、そのあたりは(前にコメントしましたように)
 運用で十分に気を付けてもらうということのほうがいいかもしれませんが。

(β) 2015/03/30(月) 07:42


(β)さまお世話になります。
検証しました。まだ検証はつづけておりますが、トラブルもなく運用できそうです。これだけ長いプログラムで支障なくすすんでいることに驚いております。そしてありがとうございます。
(β)さまが懸念している。月の変わり目でのエラー処理(例:3月が 800 で終わった。で、4月のラベル発行が4月ブックで行われ、 801が採番・・・この後、3月で1枚忘れていた・・・)の件ですが
その可能性はやはりありました。しかしそれもやはり(β)さんが提唱するように運用で対応するほうが都合が良さそうです。月の変わり目には、月末のチェックをしていますのでそのときに気付ける運用ルールで対応することにいたしました。
なんとも、先読みのすごさに・・・脱帽です。
恐縮ですがもう一つご質問があります。
ThisWorkbookモジュールに貼り付ける際に困ったことがありました。
以前、自動で10分間に1回の上書き保存するマクロ(これもこちらのサイトでお聞きしたもの)がThisWorkbookモジュール入っておりまして、とりあえずこの自動保存のマクロ(下記)をはずして、
(β)さまのかいていただいたマクロだけ貼り付け動作検証しております。
ThisWorkbookに
Private Sub Workbook_Open()
    macro1
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    On Error Resume Next
    '
    Application.OnTime EarliestTime:=myTime, _
                       Procedure:="macro1", Schedule:=False
    On Error GoTo 0
End Sub

標準モジュールに
Option Explicit

Public myTime As Date
Sub macro1()

    ThisWorkbook.Save
    myTime = Now + TimeSerial(0, 10, 0)
    Application.OnTime myTime, "macro1"
End Sub

この要件(workbook開くと10分に1回上書き保存)と今回(β)さまに書いていただいた条件付きの連番マクロを両立させることは可能でしょうか?
お手すきのときにお答えいただければ幸いです。よろしくお願いいたします

(もんぺ) 2015/03/31(火) 00:34


 基本的には、今回のコードは Changeイベントですので、問題はないはずです。
 今でも、定時(10分おき)の保存時には、シートでの入力が一瞬ロックされたような状態になっていると思うし、 それはかわりませんので。
 シート側の入力が可能になった時に入力ができるわけで、その時にChangeイベントが発生しますから。

(β) 2015/03/31(火) 01:03


 ところで、エクセルには標準で【自動バックアップ】という機能があります。

http://support.microsoft.com/ja-jp/kb/289273/ja
http://kokodane.com/tec1_23.htm

 これを設定しておけば、現在のマクロコード内での設定は一切不要になります。
 ご参考まで。

(β) 2015/03/31(火) 07:29


(β)さまお世話になります。
条件付き連番マクロ(勝手に命名)いよいよあす(4/1)から仮運用していきます。
仮運用に至るまでもいろいろ検証しましたが、エラーがみつかりません(喜)。
こんなに早く仮運用までいけるとは・・・
(β)さま、(Mook)さまのおかげです。ありがとうございます。

自動バックアップの件ご返答ありがとうございます。勉強不足でした。
運用に向け、私も簡単なメンテナンス程度ができるよう少しずつですがマクロについて勉強しております。
運用に至るまであと少し頑張りますで(私はThisWorkbookにコピー貼り付けしただけですが・・・泣)結果お知らせいたします。ありがとうございました。

(もんぺ) 2015/04/01(水) 01:19


 今回の件はすべてβさんの力ですが、エラーハンドリングの観点やデータ管理など、
 私とは違う視点がいろいろとあり、見ていて参考になりました。 

 運用上手くいくといいですね。

(Mook) 2015/04/01(水) 01:33


 よかったです。
 お仕事、がんばってください。

(β) 2015/04/01(水) 06:16


(β)さま、(Mook)さま
初日の仮運用もトラブルなく順調です。
なにより、まわりの反応が大好評で、お礼まで言われてしまって
気が引けたので、「サイト内に2人の超(スーパー)先生がいて・・・コピー貼り付け・・・というわけです」
励ましのお言葉ありがとうございます。
上司の許可もとれ、機器購入の段取りができました。(機器総額50万※うちの会社ではすごいこと)
重ね重ねありがとうございました。

(もんぺ) 2015/04/02(木) 01:04


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.