日付入力と日数計算

Question

A　　　　　　　B　　　　　
１　開始日　　H24/4/1　　　　 　
２　終了日　　H24/4/30
３　　日数　　　　　30

上のような表で、
・B1とB2に日付を入力すると、B3にB1からB2の日数が返ってくる
・B1に日付、B3に日数を入れると、B2にB1からB3日後の日付が返ってくる
・B2に日付、B3に日数を入れると、B1にB2からB3日前の日付が返ってくる
・B列から複数列同じ処理をする

というようなことがしたくて、下記のような記述をしました。
（今のところ単列処理ですが・・）

Private Sub Worksheet_Change(ByVal Target As Range) 
On Error GoTo error
    Dim a As Range
        For Each a In Target
            If a.Address = "$B$1" Then
                            
                If Range("B2") > 0 Then
                    Range("B3") = Range("B2") - Range("B1")
                ElseIf Range("B3") > 0 Then
                    Range("B2") = Range("B1") + Range("B3") - 1
                End If
            End If
    Next a

Dim b As Range
        For Each b In Target
            If b.Address = "$B$2" Then
                            
                If Range("B1") > 0 Then
                    Range("B3") = Range("B2") - Range("B1") + 1
                ElseIf Range("B3") > 0 Then
                    Range("B1") = Range("B2") - Range("B3") - 1
                Else
                    Range("B2") = ""
                End If
            End If
    Next b

Dim c As Range
        For Each c In Target
            If c.Address = "$B$3" Then
                            
                If Range("B1") > 0 Then
                    Range("B2") = Range("B1") + Range("B3") + 1
                ElseIf Range("B2") > 0 Then
                    Range("B1") = Range("B2") - Range("B3") - 1
                Else
                    Range("B2") = ""
                End If
            End If
    Next c

error:

End Sub

これだと、例えば
B1に日付を入力して、B3に日数を入力すると、
B2に日付が返ってくるのですが、B2に日付が返った瞬間にループ処理してしまいます。
（『WorksheetChenge』なので当然なのですが…）

どうすればうまくいくか、ご教示お願いいたします。

また、この計算を複数列で行いたいので、それもあわせて
教えていただけると幸いです。

よろしくお願いします。

piyo_dansyaku · Accepted Answer

内容は、概ね良いように思います。
Select Caseを勧めましたが、文字列比較に相応しいとは言えないのでif文に戻しました。失礼しました。

＞一応やりたいとおりに動いてはくれていますが…
目的は、仕様通りに動かしたい事でしょうか。それとも、勉強等や仕事で活かしたいのでしょうか。

＞すこし構文が長くなってしまったので、もう少し
＞短くできる（簡単に？）できますでしょうか？
「短く」は下記処理及び、未実装のエラー処理、仕様追加により幾分か増えると思います。
ので、「簡単」を意識して作り直してみましたが、いかがでしょうか。

'--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--'
'機能名：日付変更機能
'概要  ：変更したセルの情報を元に、日付の自動計算を動的に行う
'仕様(1)：制約として、1行目、2行目の入力値は日付。3行目は日数を入力
'仕様(2)：B1とB2に日付を入力した場合、B3にB1からB2の日数が返ってくる
'仕様(3)：B1に日付、B3に日数を入力した場合、B2にB1からB3日後の日付が返ってくる
'仕様(4)：B2に日付、B3に日数を入力した場合、B1にB2からB3日前の日付が返ってくる
'作成日：4/6
'--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--'

'メンバー変数
Private m_MacroRunFlag As Boolean  '計算処理判定用フラグ

'--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--'
'プロシージャ名：Worksheet_Change
'引数          ：変更セル
'概要          ：セルの値を変更時、日付の計算処理を呼出す
'--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--'
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo error

'変更したセルの多重実行を回避するためフラグ用い回避
If m_MacroRunFlag = False Then
    m_MacroRunFlag = True
    '日付計算処理の呼出し
    calcDate (Target.Address)
 End If

'メンバー変数が初期化されないため、フラグを元に戻しておく
m_MacroRunFlag = False
error:

End Sub

'--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--'
'プロシージャ名：calcDate
'引数          ：変更セルのアドレス
'概要          ：セルのアドレスを元に日付計算を行う
'--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--'
Private Sub calcDate(ByVal getAddress As String)
    Dim bfRngAlph As String
    Dim line As String
    
    '初期化
    rngAlph = ""
    line = ""
    '列のアルファベットを取得
    rngAlph = getAlph(getAddress)
    line = getLine(getAddress)
============================
    '1行目の変更時の処理
    '2行目の変更時の処理
　　'ここは3行目をベースで。
============================

'3行目の変更時の処理
    If StrComp(line, "3") = 0 Then
        If Range(rngAlph + "1") > 0 Then
          Range(rngAlph + "2") = Range(rngAlph + "1") + Range(rngAlph + "3") + 1
        ElseIf Range(rngAlph + "2") > 0 Then
          Range(rngAlph + "1") = Range(rngAlph + "2") - Range(rngAlph + "3") - 1
        Else
          Range(rngAlph + "2") = ""
        End If
    End If
End Sub

'--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--'
'プロシージャ名：getAlph
'引数          ：変更セルのアドレス
'概要          ：セルのアルファベットを取得
'--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--'
Private Function getAlph(ByVal getAddress As String) As String

Dim rngAlph As String
    '初期化
    rngAlph = ""
    '列のアドレスを取得
    rngAlph = getAddress
    'アドレスの長さが5文字の場合
    If Len(rngAlph) = 5 Then
      rngAlph = Mid(rngAlph, 2, 2)
    'アドレスの長さが4文字の場合
    ElseIf Len(rngAlph) = 4 Then
      rngAlph = Mid(rngAlph, 2, 1)
    End If
    
    '呼出元にアルファベットを返す
    getAlph = rngAlph
End Function

'--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--'
'プロシージャ名：getLine
'引数          ：変更セルのアドレス
'概要          ：セルの行数を取得
'--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--'
Private Function getLine(ByVal getAddress As String) As String

Dim line As String
    '初期化
    line = ""
    '列のアドレスを取得
    line = getAddress
    'アドレスの長さが5文字の場合
    If Len(line) = 5 Then
      line = Mid(line, 5, 1)
    'アドレスの長さが4文字の場合
    ElseIf Len(line) = 4 Then
      line = Mid(line, 4, 1)
    End If
    
    '呼出元に行数を返す
    getLine = line
End Function

piyo_dansyaku · Answer

単一セルの制御は実装できたという事でよいですか？

ブレークポイントについて

http://www.vba-world.com/breakpoint.html

ウォッチ式について

http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_040_025.html

Countについて

実装
'Ａ．Countが1の場合、単一セル
'Ｂ．Countが1より大きい場合、複数セル
IF Target.Count = 1 Then
'実装したい処理
End IF

解説
今回の場合、Countで取得する数＝選択セルの数を意味します。
つまり、1より大きい場合、複数セルが選択していると判別できます。
ブレークポイントを設定した箇所で、ウォッチ式「Target.Count」を指定するとより実感しやすいかなと（ブレークポイント使い方がわかるといいですが）。

老婆心ながら、今後、このマクロを改造したり、新しいマクロを作ろうと思っているのであれば、ブレークポイントを設定してウォッチ式で値をみる方法を身につけておいたほうがよいと思います。

piyo_dansyaku · Answer

＞できれば単一セルおよび複数セルを消去した時の挙動も教えていただけるとありがたいです。

(1)単一セルの消去時の挙動について
Deleteキー押下時の場合、Rangeの値が「空」になります。
したがって、空の時の判定文を入れるだけで解決します。

変数の値は、
１．「ブレークポイント」を設定し、デバッグ実行
２．「ウォッチ式の追加」でTargetを指定

で確認できます

(2)複数セルの消去時の挙動について
こちらについては、(1)の実装でごまかす事は可能です
ごまかさないのであれば、Countあたりで制御をかければよいかと思います

piyo_dansyaku · Answer

3行とも入力されていて、いずれかのセルの値を消した場合の挙動については「あえて」実装しませんでした。

理由は、下記の通りです。

(1)仕様として謳っていない事に気づいて欲しかった
(2)ご自身で実装できる内容だと思った

また、上記以外の仕様で、複数セルを一括で消した場合の仕様は必要ないでしょうか？

今の作りは、「なんとなくそれっぽく動いている」ようには見えますが、複数セルのイベントは考慮して作っていません。

piyo_dansyaku · Answer

他の方が単数列を回答しているので、僕からは複数列を。

雑ではありますが、こんな感じでしょうか
注意点としては、AA列が出てきた場合は考慮が必要です。
レングスを取得し、if文等をかませばよいかと思います。
あと、1列目1行目～1列目3行目はif文よりSelect Caseのほうが、より見やすいかも

Private m_MacroRunFlag As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo error

If m_MacroRunFlag = False Then
        
    Dim rngAlphCode As String
    'AA列が必要な場合、レングスを取得しMidの引数を指定したりする必要あり
    rngAlphCode = ""            '列のアルファベットを取得
    rngAlphCode = Target.Address
    rngAlphCode = Mid(rngAlphCode, 2, 1)
    m_MacroRunFlag = True
    
    '1列目1行目の変更時の処理
    '1列目2行目の変更時の処理
    '1列目3行目の変更時の処理

If Target.Address = "$" + rngAlphCode + "$3" Then
        If Range(rngAlphCode + "1") > 0 Then
          Range(rngAlphCode + "2") = Range(rngAlphCode + "1") + Range(rngAlphCode + "3") + 1
        ElseIf Range(rngAlphCode + "2") > 0 Then
          Range(rngAlphCode + "1") = Range(rngAlphCode + "2") - Range(rngAlphCode + "3") - 1
        Else
          Range(rngAlphCode + "2") = ""
        End If
    End If

End If

m_MacroRunFlag = False
error:

End Sub

1380649874335 · Answer

No4で回答した者です。
変な回答になってしまいました。無視して下さい。
（すみません。）

1380649874335 · Answer

長文です。
３点質問があります。

1）日付や日数を求めるのに、ループ処理が必ず必要なのでしょうか？
　 そうでないのならば、「DateDiff関数」、「DateAdd関数」を
   使った方が楽だと思います。
      http://www.eurus.dti.ne.jp/yoneyama/Excel/vba/function/vba_date.html

2）いまいち仕様でよく分からない部分があります。
   それぞのセル入力時の正しい仕様を教えて下さい。

＜B1の入力時＞
　[B2,B3共に空白の場合]
    =>
　[B2に日付があり、B3は空白の場合]
    =>
　[B2が空白で、B3に数値がある場合]
    =>
　[B2に日付があり、B3に数値がある場合]
    =>

＜B2の入力時＞
　[B1,B3共に空白の場合]
    =>
　[B1に日付があり、B3は空白の場合]
    =>
　[B1が空白で、B3に数値がある場合]
    =>
　[B1に日付があり、B3に数値がある場合]
    =>

＜B3の入力時＞
　[B1,B2共に空白の場合]
    =>
　[B1に日付があり、B2は空白の場合]
    =>
　[B1が空白で、B2に日付がある場合]
    =>
　[B1、B2共に日付がある場合]
    =>

3）数値や日付以外が入力された場合はどうしたいと
　 お考えですか？

以上です。

MARU4812 · Answer

古典的な鉄版の手法はフラグで最小限の範囲のみ処理を飛ばす。
Option Explicit
Private m_MacroRunFlag As Boolean

Private Sub Worksheet_Change(ByVal Target As Range)
If m_MacroRunFlag = True Then Exit Sub

m_MacroRunFlag = True
Me.Range("B1") = Me.Range("B2") - Me.Range("B3") - 1
m_MacroRunFlag = False

End Sub

Tom-3 · Answer

更新セルのターゲットを確定して変更する方法でどうでしょうか？
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim StrErrMsg As String

On Error GoTo Worksheet_Change_Err

If Target.Column = 2 And Target.Row = 1 Then
　　　If Range("B1") > 0 And Range("B2") > 0 And Range("B3") > 0 Then
　　　　If Range("B2") = DateAdd("d", Range("B3"), Range("B1")) Then
　　　　　　Exit Sub
　　　　End If
　　End If

If Range("B2") > 0 And _
　　　 (Range("B3") = 0 Or Range("B3") = "" Or Range("B3") = Null) Then
　　　　Range("B3") = Range("B2") - Range("B1")
　　　　Exit Sub
　　Else

Range("B2") = DateAdd("d", Range("B3"), Range("B1"))
　　　　Exit Sub
　　End If
　　
　　
End If

If Target.Column = 2 And Target.Row = 2 Then
　　If Range("B1") > 0 And Range("B2") > 0 And Range("B3") > 0 Then
　　　　If Range("B2") = DateAdd("d", Range("B3"), Range("B1")) Then
　　　　　　Exit Sub
　　　　End If
　　End If

If Range("B1") > 0 And _
　　　 (Range("B3") = 0 Or Range("B3") = "" Or Range("B3") = Null) Then
　　　　Range("B3") = Range("B2") - Range("B1")
　　　　Exit Sub
　　Else

Range("B1") = DateAdd("d", Range("B3") * -1, Range("B1"))
　　　　Exit Sub
　　End If
　　
　　
End If

If Target.Column = 2 And Target.Row = 3 Then

If Range("B1") > 0 And Range("B2") > 0 And Range("B3") > 0 Then
　　　　If Range("B2") = DateAdd("d", Range("B3"), Range("B1")) Then
　　　　　　Exit Sub
　　　　End If
　　End If

If Range("B3") > 0 And _
　　　 (Range("B1") = 0 Or Range("B1") = "" Or Range("B1") = Null) Then
　　　　Range("B1") = DateAdd("d", Range("B3") * -1, Range("B2"))
　　　　Exit Sub
　　Else
　　　　Range("B2") = DateAdd("d", Range("B3"), Range("B1"))
　　　　Exit Sub
　　End If
　　
　　
End If

Exit Sub
Worksheet_Change_Err:
　　If Err.Number <> 0 Then
　　　　StrErrMsg = ""
　　　　StrErrMsg = StrErrMsg & "処理中にエラーが発生しました！！" & Chr(13) & Chr(10)
　　　　StrErrMsg = StrErrMsg & "「エラーコード：" & Err.Number & "」" & Chr(13) & Chr(10)
　　　　StrErrMsg = StrErrMsg & "「エラー内容：" & Err.Description & "」です" & Chr(13) & Chr(10)
　　　　StrErrMsg = StrErrMsg & "処理を中断します！！" & Chr(13) & Chr(10)
　　　　MsgBox StrErrMsg, vbCritical, "エラー"
　　End If
　　Exit Sub
End Sub

nda23 · Answer

イベントを停止させたら如何でしょう。
プロシージャの最初と最後にに以下の
文を置けばよいと思います。

Private Sub Worksheet_Change(ByVal Target As Range) 
Application.EnableEvents = False
　　　＝＝中略＝＝
Application.EnableEvents = True
End Sub

途中でExit Sub しないでね。

日付入力と日数計算

内容は、概ね良いように思います。

単一セルの制御は実装できたという事でよいですか？

＞できれば単一セルおよび複数セルを消去した時の挙動も教えていただけるとありがたいです。

3行とも入力されていて、いずれかのセルの値を消した場合の挙動については「あえて」実装しませんでした。

他の方が単数列を回答しているので、僕からは複数列を。

No4で回答した者です。

長文です。

古典的な鉄版の手法はフラグで最小限の範囲のみ処理を飛ばす。

更新セルのターゲットを確定して変更する方法でどうでしょうか？

イベントを停止させたら如何でしょう。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング