[[20160924233122]]　『セルに入力した数字を毎日減らす』（せい）　ページの最後に飛ぶ

『セルに入力した数字を毎日減らす』（せい）

例えばａ１セルに５と入力する。次の日になると４になる
Ａ１の数字は変更する時もある
このようなことはできるでしょうか」

このＡ１は行挿入や行削除で場所が変わります

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

 セルの場所が変わっていくということに関しては、このセルに名前をつけ、その名前を参照すればＯＫですけど
 セルに 5 と入っているものを 4 にかえることは関数では不可能です。
 実現するにはマクロになります。

（β） 2016/09/25(日) 00:21

マクロも想定していました
少しづつ勉強中です
スキルアップのためにもよろしくお願いします
（せい） 2016/09/25(日) 00:28

 まず、数字を入れるセル、たとえば A1 に　「番号」という名前を付けてください。
 もう１つ、どのシートでもいいですし、また、そこのどこでもいいですけど　作業セルにします。
 その作業セルに　「加算日」という名前を付けてください。
 このシートは、目障りなら非表示シートにしておいてもＯＫです。

 で、ThisWOrkbookモジュール(VBE画面左上のプロジェクトエクスプローラのThisWorkbookをダブルクリックしてでてくるところ）に
 以下をはりつけ、いったん保存して閉じてください。

 １日の中で最初に開いたときに　自動加算します。自動加算されれば、その日は、何度開き直しても自動加算はしません。

 なお、ブックをあけたまま、じぃっと眺めていて、日付が変更になった場合は、自動加算しません。

 Private Sub Workbook_Open()
    If Range("加算日").Value <> Date And Not IsEmpty(Range("番号")) Then
        Range("番号").Value = Range("番号").Value - 1
        Range("加算日").Value = Date
    End If
 End Sub

（β） 2016/09/25(日) 06:16

 ↑　セルの名前は何でもいいので、好きな名前に変更いただいてもＯＫです。
 特に、処理としては　減算　しているわけですから　加算日　じゃなく　減算日　でも　自動処理日　でもいいですね。

（β） 2016/09/25(日) 06:31

マクロではないのですが
A1にこんな式を入力
=42645-TODAY()

必要に応じて、数字の部分を修正して使います

（マナ） 2016/09/25(日) 07:37

βサン　マナサン
有難うございます
マクロの確認のため１分おきとか
へんこうすることはできますか

（せい） 2016/09/25(日) 11:13

PCの日付を一時的に変更して確認できませんか。

（マナ） 2016/09/25(日) 11:19

 >『セルに入力した数字を毎日減らす』

毎日ということから開かない日があってもということだと思います。

βさんのマクロだと　数日過ぎていたらその日数が反映されないので

加算日と開いた日の日数を計算しないといけないですよね。
（?） 2016/09/25(日) 14:13

1分おきに変更するとはどういうことですか？
１日単位で変わるのに、1分おきにですか？
１日使わないとかいう噂もあるし、どうしたらいいのか。
何が目的でしたっけ、勉強？
（γ） 2016/09/25(日) 14:42

いや、勉強でも一向かまわないのですが、
仕様、したいことを明確にして欲しいだけです。
　
１分おきに自動更新するのなら、
Application.OnTimeで繰り返しマクロ実行ということになる。
でも、それは、Excelが開いていることが条件。
閉じていても、自動的に開いて更新して閉じるとかいうことになれば、
タスク管理の話になります。
　
範囲を余り広げないほうが無難と思うけどねえ。
（γ） 2016/09/25(日) 15:06

動作確認のため何日もかけられないということです。
（?） 2016/09/25(日) 15:33

 >>動作確認のため何日もかけられないということです。

 レスされた　(?)さんって、質問者のせいさんですか？
 せいさんの要望に対して、γさんが意図を質問され、その返事をしておられるので・・・？

 いずれにしても、毎日開かないこともある、ひらいた場合は、開かなかった期間分、減算をしたいという要件かもしれません。
 金曜日に開いて減算されたあと、土日をはさんで月曜日に開く場合は、往々にしてあるでしょうし。
 また、減算していって 0 になったら、そのままマイナスになっていくのかどうか。

 そういったことは、質問者さんが、明確に要件として提示いただきたいですね。

 で、マクロ動作確認のためということであれば、マナさんからレスがあるように、ＰＣ日付を変えて検証するというのが
 最も早く確かめられる方策でしょうね。

 1分ごとにチェックするということなら、γさん指摘のように繰り返し処理になりますし、そうすると
 コードそのものが異なってきますので、それで検証しても、オリジナルコードの検証にはなりませんよね？

（β） 2016/09/25(日) 16:47

 こんにちわ。

 (?)さんが質問者さんかは分かりませんが、
 質問者さんの1分毎と言うのは動作確認するのに次の日まで待たないといけないのを、早く確認したいと言う事だと思います。

 βさんのコードの2か所のDateをNowに変えると1ミリ秒単位での管理になるので、開く度にマクロが実行されるようになります。

（sy） 2016/09/25(日) 17:21

みなさんどうもありがとうございます
１分毎というのはｓｙさんのいうととおり動作確認が目的です
？サンのおっしゃるとおり開かない日もあります
基本的に土日は開きません例外もありますが
動作の確認はｐｃの変更をします
減算で０になった後ですが０のまま表示されるように
したいです

（せい） 2016/09/25(日) 19:06

 で、開かなかった日が２日あるとすれば３日目に開いたとき、 -1 ですか？　-3 ですか？

（β） 2016/09/25(日) 19:24

期限まで残り何日？みたいな話なら
A1:=MAX("2016/10/1"-TODAY(),0)

（マナ） 2016/09/25(日) 19:33

βさん三日目でー３です
まなさん期限という感じではなく
予定の日数で３日かかる予定で１日前になったとき
やっぱりあと２日かかるとおもったらカウントダウンされ１になったとこを
２にへんこうします

（せい） 2016/09/25(日) 21:25

 そういう要件であれば、まず名前（なんでもいいとはいいながら）は、「残日数」と「判定日」といったものがいいですね。
 で、最初、判定日セルには、今日の日付を 2016/9/26 といった形でいれておいてください。

 コードですけど、以下のように　判定なしで無条件で処理可能です。
 なお、確認ですが、

 ・判定日　欄に　過去日　をいれる。
 ・コードの　任意の場所をクリックして、F8 を押しながらステップ実行を行う。
 ・実行結果を確認する。

 こんな手順で、ＰＣ日付の変更なし、ブックの再オープンなし　で、確認可能です。

 Private Sub Workbook_Open()
    Range("残日数").Value = WorksheetFunction.Max(0, Range("残日数").Value - DateDiff("d", Range("判定日").Value, Date))
    Range("判定日").Value = Date
 End Sub

（β） 2016/09/26(月) 07:20

βさん
ありがとうございました
コードの確認もでき、希望通りの処理になりました
また、意見等下さった皆様もありがとうございました

（せい） 2016/09/26(月) 11:29

突然ですが追加で問題が発生してしまいました
判定日についてＱ列のセルに数字（残日数）を入力すると判定日（Ｐ列）にその日の
日付が入るコードを使用しています。
この日付から残日数を計算していますが
表のような形になっており０日（終了）になったら行ごと削除することになっています
削除された下の行が繰り上がるのですが繰り上がった日から残日数を計算しなくてはいけないのですが
そのまま残ってしまいます。
なにか良い方法はないでしょうか
現在使用している表の形とコードを記載します。

A 　B C 　D　 E　　~ O P　 Q
ＤＤ　　　　　　　　　　　9/24　 1
ＨＨ　　　　　　　　　　　9/23 　 5

9/25日に上の１行を削除するとしたのようにしたい

A 　B C 　D　 E　　~ O P　 Q
ＨＨ　　　　　　　　　　　9/23 　5

この削除もコードを使いＤＥＬした後に貼り付けをしています

ーーーーーー入力日表示ーーーーー
Private Sub Worksheet_Change(ByVal Target As Range)

 If Target.Column <> 17 Then Exit Sub   'Q列指定
 Application.EnableEvents = False
 Target.Offset(, -1).Value = Date
 Application.EnableEvents = True
 End Sub

ーーーーー残数計算ーーーー
Private Sub Workbook_Open()

 　Range("日数").Offset(1, 0).Value = Range("日数").Value - DateDiff("d", Range("記入日").Value, 　 　Range("今日").Value)
End Sub

ーーーーーー終了行削除（移動）－－－－－－
Private Sub CommandButton5_Click() '作業完了品の移動

Application.ScreenUpdating = False

Dim acc, acs, acr, i, j As Integer

Dim myRow As Integer, myCol As Integer

    myRow = ActiveCell.Row      'セルの行番号取得
    myCol = ActiveCell.Column  'セルの列番号取得

    Cells.Select    'シートの選択-----範囲指定も可能-----
    ActiveSheet.Unprotect      'シートの保護解除

    Cells(myRow, myCol).Select     '選択したセルへ戻る

acs = ActiveCell.Row ' 現在のセル位置
acss$ = "[完了品]" ' 開始位置参照マーク"

Const LineMAX = 3000

acc = ActiveCell.Column ' 現在のセル位置

If (acc <> 1) Then
'If (acc <> 1 Or ActiveCell.Value = "") Then

    Err = MsgBox("カーソル位置が不正です", vbOKOnly, "1行削除")
          Application.ScreenUpdating = True

    End
End If

i = ActiveCell.Row
acc1 = i
While (i < LineMAX And Cells(i, "A").Value <> acss$) '目標開始位置検索

   i = i + 1
Wend
If (i >= LineMAX) Then
    Err = MsgBox("移動先が見つかりません", vbOKOnly, "完了品移動")
          Application.ScreenUpdating = True

    End
End If
acc2 = i
While (i < LineMAX And Cells(i, "A").Value <> "")
   i = i + 1
Wend
If (i >= LineMAX) Then
    Err = MsgBox("移動先がいっぱいです", vbOKOnly, "完了品移動")
          Application.ScreenUpdating = True

    End
End If
acc3 = i

'移動実行
Range(Cells(acc1, "a"), Cells(acc1, "Q")).Copy Destination:=Range(Cells(acc3, "a"), Cells(acc3, "Q"))

compflag = 1
compline1 = acc1
compline3 = acc3
CommandButton6.Enabled = True

Rows(acc1).Select
Selection.Delete

ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _

        False      'シートの保護
      Application.ScreenUpdating = True

End Sub

Private Sub CommandButton6_Click() '作業完了品移動取り消し

Dim myRow As Integer, myCol As Integer

    myRow = ActiveCell.Row      'セルの行番号取得
    myCol = ActiveCell.Column  'セルの列番号取得

    Cells.Select    'シートの選択-----範囲指定も可能-----
    ActiveSheet.Unprotect      'シートの保護解除

    Cells(myRow, myCol).Select     '選択したセルへ戻る

If compflag = 1 And CommandButton6.Enabled = True Then

   compflag = 0
   acs = compline3
   acd = compline1 - 1
   CommandButton6.Enabled = False
   Rows(acd).Select
   Selection.Copy
   Rows(acd + 1).Select
   Selection.Insert
   Range(Cells(acs, "a"), Cells(acs, "Q")).Copy Destination:=Range(Cells(acd + 1, "a"), Cells(acd + 1, "Q"))
   Range(Cells(acs, "a"), Cells(acs, "Q")).ClearContents
End If

ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _

        False      'シートの保護

End Sub

（せい） 2016/09/26(月) 13:30

 コードはまだ読んでいませんが、アップされたこれらのコード、どのモジュールに書いてあるのですか？
 それと、名前を付けたセルですけど、具体的にはどのセルですか？

（β） 2016/09/26(月) 22:35

入力日表示がｓｈｅｅｔ１
残数と削除はＴｈｉｓｗｏｒｋｂｏｏｋです
日数がＱ６、記入日がＰ６、今日がＵ１です
６行目から表があります
６行目を削除（コード）すると７行目が６行目になります
６行目に新しく違うデータを挿入することもあります
その場合元の６行目から下は下段にスライドします
今日のＵ１は固定ですＴＯＤＡＹ関数を設定しています

このような追記で大丈夫ですか
（せい） 2016/09/26(月) 23:48

新しいデータを入れたときは残数を入力するので記入日はコードが動きます
削除されたことで繰り上がった日数がセルに入力した形ではないので
記入日のコードが走らないのでは？と思っています
（せい） 2016/09/26(月) 23:53

 えっ？

 ーーーーーー終了行削除（移動）－－－－－－ と記述されている下には
 CommandButton5_Click と CommandButton6_Click がありかすけど、ThisWorkbookモジュールですか？？？？

（β） 2016/09/27(火) 08:56

 説明を読んで、さらに　？？？？？　になりました。

 名前を付けたセル、６行目にありますよね。
 従来は、この部分のみでの処理でしたけど、今回は？

 6行目から複数行のデータがあって、その行の残日数が 0　になると、その行を削除？
 6行目が削除になると、名前の付けられたセルの削除されますので、その後のコード実行でエラーになりますが？

 挿入等でセルの場所が変化してしまうということだったので、セルに名前を付ける提案をしたんですが・・・

 そうではなく、６行目から始まるデータ行のＱ，Ｐ列にそれぞれの行の記入日と残日数があるということですか？

 そういったことであれば、全く違った組み立てになります。
 つまり、最初の要件とは全く別の、新しいテーマになります。最初のテーマの延長ということではないですよ。

 最初のテーマのコードを、全く異なる要件、仕様のブックに対して実行させて、不具合がでるのは、あたりまえです。

（β） 2016/09/27(火) 09:13

 今回提示された要件であれば、以下（だと思います。想像です）
 名前を付けるセルは、「今日」だけでＯＫ。他の名前つきセルは不要です。
 対象のシートを★で規定しています。実際のものに直してください。

 残 0 になった時の削除は、その時点（瞬間）には行わず 0 で残しています。
 削除は（ブックを閉じるときの保存も含めて）上書き保存時に該当行を削除しています。

 なお、CommandButton5_Click と CommandButton6_Click でやっていることに関しては、含めていません。
 何をやりたいのかの説明をもらっていないので。

 以下、すべて ThisWorkbookモジュールです。

 Const SHN As String = "Sheet1" '★

 Private Sub Workbook_Open()
    Dim r As Range
    Dim c As Range

    Application.EnableEvents = False

    Set r = GetArea(SHN)

    For Each c In r.Cells
        c.Value = WorksheetFunction.Max(0, c.Value - DateDiff("d", c.EntireRow.Range("P1").Value, Range("今日").Value))
        c.EntireRow.Range("P1").Value = Range("今日").Value
    Next

    Application.EnableEvents = True

 End Sub

 Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim r As Range
    Dim i As Long

    Application.EnableEvents = False

    Set r = GetArea(SHN)
    For i = r.Rows.Count To 1 Step -1
        If Not IsEmpty(r.Cells(i)) And r.Cells(i).Value = 0 Then r.Cells(i).EntireRow.Delete
    Next

    Application.EnableEvents = True

 End Sub

 Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
    Dim a As Range
    Dim r As Range
    Dim c As Range

    If sh.Name <> SHN Then Exit Sub

    Set r = GetArea(SHN)
    Set a = Intersect(Target, r.EntireRow.Columns("Q"))
    If a Is Nothing Then Exit Sub

    If sh.Name <> SHN Then Exit Sub

    Application.EnableEvents = False

    For Each c In a.Cells
        c.EntireRow.Range("P1").Value = Range("今日")
    Next

    Application.EnableEvents = True

 End Sub

 Private Function GetArea(SHN As String) As Range
    With Sheets(SHN)
        Set GetArea = .Range("A6", .Range("A" & Rows.Count).End(xlUp)).Columns("Q")
    End With
 End Function

（β） 2016/09/27(火) 10:17

大変失礼しました
私の勘違いというより間違えていました
記入日と削除はＳｈｅｅｔ1、残数処理がThisworkbookでした
さらに
セルに名前を付けたところは日数がQ5、記入日がP5、今日がU1です
そして、前回省いてしまいましたがQ5、P5には=INDIRECT("R[1]C",FALSE)として
Q6、P6をそれぞれ参照しています
6行目を削除すると次の行が6行目になりQ5、P5がそれぞれ変化するように。

コマンドボタンについてはA～Qをコピーして別なところに貼り付け
コピーした行を削除といった処理をしています。

（せい） 2016/09/27(火) 11:39

 CommandButton処理は、コメントした通り読んでいませんし、まず、そこは後回しにしましょう。
 もし、ここでの要件を【言葉できちんと】説明いただければ、「本線の処理」が片付いたあとに引き続き
 お手伝いもできるかと。でも、今は後回し。

 「本線」の処理ですけど、もう一度確認します。

 もともとは、１つだけ、あるセルに残日数が入っていて、ブックを開くたびに、前回の値を、日数分、マイナスしていくという
 ただ、それだけの話でしたよね？

 でも、あとからでてきたレイアウトを見ると、６行目以降に日付と残日数がある行がずらっと存在し、
 その中で 残日数が　0 になった行を削除したいと、全く別のテーマになっているわけですよね？
 そういった方向でコードをアップしました。

 まず、アップしたコードだけでやってみて、理解が間違っているのか間違っていないのか確認願います。

（β） 2016/09/27(火) 12:50

たびたびすいません

もともとは、１つだけ、あるセルに残日数が入っていて、ブックを開くたびに、前回の値を、日数分、マイナスしていくという
ただ、それだけの話でしたよね？

その通りです。
残日数が０になるのは6行目だけです
6行目が０になると下の行が繰り上がりまた日数がカウントダウンされるということです
7行目以降は記入日も残日数も6行目になるまでは変わりません

エクセルでガンチャート風の日程表を作成しています
これらでご理解いただけたでしょうか
説明が不足しすいません

（せい） 2016/09/27(火) 14:37

よく考えると6行目だけ残数がかわるので
Private Sub Worksheet_Change(ByVal Target As Range)

 If Target.Column <> 17 Then Exit Sub   'Q列指定
 Application.EnableEvents = False
 Target.Offset(, -1).Value = Date
 Application.EnableEvents = True
 End Sub

これって必要ないのかもしれないです
6行目になった日付だけあれば良いような気がしてます
混乱させてしまい申し訳ありませんが
いかがでしょうか

（せい） 2016/09/27(火) 15:16

 つまり、残日数を変更するのは 6 行目だけ、その下のものは行が繰り上がるだけということなんですね。
 （そういうことは、要件としてきわめて大事なことですから、最初に、しっかりと説明して下さい。
 こちらは　せい　さんの頭の中まではのぞけないですから）

 のちほど、コード案アップします。

（β） 2016/09/27(火) 17:00

 コード案です。というか、一番最初にアップしたものとそんなにかわりません。
 常に P6,Q6を相手にしますので、名前つきセルは　「今日」のみ参照。

 P5,Q5 の数式は、必要性がわかりませんけど、いずれにしても以下のコードでは参照していません。

 またそちらのWorkSheet_Change ですけど、ここも何をしたいのかがわからないので、コメントできません。
 6行目以外でも、とにかく Q6から下のQ列の変更があれば、P列の日付を【今日】にしたいなら、そういった
 コードにすればいいと思います。（そういった要件だったつぃても、現在のそちらのコードでは不十分なところがありますが）

 なお、繰り返しになりますが CommandButton関連プロシジャは、そこで、具体的に何をどうしたいのか
 言葉で説明いただいていないので、これもコメントできません。

 ThisWorkbookモジュールを以下のみにしてください。
 ビック開いて、6行目の残日数をメンテして結果が0なら行削除しています。

 Private Sub Workbook_Open()

    Application.EnableEvents = False

    With Sheets("Sheet1")   '★実際のシート名に
        .Range("Q6").Value = WorksheetFunction.Max(0, .Range("Q6").Value - DateDiff("d", .Range("P6").Value, Range("今日").Value))
        .Range("P6").Value = Range("今日").Value
        If .Range("Q6").Value = 0 Then .Rows(6).Delete
    End With

    Application.EnableEvents = True

 End Sub

（β） 2016/09/27(火) 17:19

β殿
大変失礼しました
提示いただいたコードで問題ありませんでした
次回質問するときは説明をしっかりできるように
していきます

（せい） 2016/09/28(水) 22:52

コメント返信：

[ 一覧(最新更新順) ]

[[20160924233122]] 『セルに入力した数字を毎日減らす』（せい） ページの最後に飛ぶ

[[20160924233122]]　『セルに入力した数字を毎日減らす』（せい）　ページの最後に飛ぶ