Excel VBAで日付の入力と日数計算を行う方法
- Excel VBAを使用して、日付の入力と日数計算を行う方法について説明します。
- 具体的な処理としては、B1とB2に日付を入力すると、B3にB1からB2の日数が返ってきます。また、B1に日付、B3に日数を入れると、B2にB1からB3日後の日付が返ってきます。さらに、B2に日付、B3に日数を入れると、B1にB2からB3日前の日付が返ってきます。
- 上記の処理を複数の列に適用することも可能です。
- ベストアンサー
日付入力と日数計算
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』なので当然なのですが…） どうすればうまくいくか、ご教示お願いいたします。 また、この計算を複数列で行いたいので、それもあわせて 教えていただけると幸いです。 よろしくお願いします。
- OGN
- お礼率100% (17/17)
- Visual Basic
- 回答数10
- ありがとう数10
- みんなの回答 （10）
- 専門家の回答
質問者が選んだベストアンサー
内容は、概ね良いように思います。 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
その他の回答 (9)
- piyo_dansyaku
- ベストアンサー率75% (12/16)
単一セルの制御は実装できたという事でよいですか？ ブレークポイントについて 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
- ベストアンサー率75% (12/16)
＞できれば単一セルおよび複数セルを消去した時の挙動も教えていただけるとありがたいです。 (1)単一セルの消去時の挙動について Deleteキー押下時の場合、Rangeの値が「空」になります。 したがって、空の時の判定文を入れるだけで解決します。 変数の値は、 １．「ブレークポイント」を設定し、デバッグ実行 ２．「ウォッチ式の追加」でTargetを指定 で確認できます (2)複数セルの消去時の挙動について こちらについては、(1)の実装でごまかす事は可能です ごまかさないのであれば、Countあたりで制御をかければよいかと思います
お礼
ご回答ありがとうございます。 返信が大変遅れてしまい申し訳ありません。 ＞１．「ブレークポイント」を設定し、デバッグ実行 ＞２．「ウォッチ式の追加」でTargetを指定 ＞(2)複数セルの消去時の挙動について ＞こちらについては、(1)の実装でごまかす事は可能です ＞ごまかさないのであれば、Countあたりで制御をかければよいかと思います どちらもいろいろ考えたり調べたのですが、 どうしてよいのかさっぱりわかりませんでした。 よろしかったらご教示いただけますでしょうか。 よろしくお願いします。
- piyo_dansyaku
- ベストアンサー率75% (12/16)
3行とも入力されていて、いずれかのセルの値を消した場合の挙動については「あえて」実装しませんでした。 理由は、下記の通りです。 (1)仕様として謳っていない事に気づいて欲しかった (2)ご自身で実装できる内容だと思った また、上記以外の仕様で、複数セルを一括で消した場合の仕様は必要ないでしょうか？ 今の作りは、「なんとなくそれっぽく動いている」ようには見えますが、複数セルのイベントは考慮して作っていません。
お礼
ご回答ありがとうございます。 消去時の挙動については全く謳ってありませんでした。 すいません。 できれば単一セルおよび複数セルを消去した時の 挙動も教えていただけるとありがたいです。 単一・複数とも消去時には再計算しないような仕様が できればいいなと思っています。 どうぞよろしくお願いします。
- piyo_dansyaku
- ベストアンサー率75% (12/16)
他の方が単数列を回答しているので、僕からは複数列を。 雑ではありますが、こんな感じでしょうか 注意点としては、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
お礼
ご回答ありがとうございます。 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行目の変更時の処理 Select Case Target.Address Case "$" + rngAlphCode + "$1": If Range(rngAlphCode + "2") > 0 Then Range(rngAlphCode + "3") = Range(rngAlphCode + "2") - Range(rngAlphCode + "1") + 1 ElseIf Range(rngAlphCode + "3") > 0 Then Range(rngAlphCode + "2") = Range(rngAlphCode + "1") + Range(rngAlphCode + "3") - 1 End If Case "$" + rngAlphCode + "$2": If Range(rngAlphCode + "1") > 0 Then Range(rngAlphCode + "3") = Range(rngAlphCode + "2") - Range(rngAlphCode + "1") + 1 ElseIf Range(rngAlphCode + "3") > 0 Then Range(rngAlphCode + "1") = Range(rngAlphCode + "2") - Range(rngAlphCode + "3") + 1 End If Case "$" + rngAlphCode + "$3": 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 End If End Select End If m_MacroRunFlag = False error: End Sub というふうに記述うしたのですが こんな感じでよかったのでしょうか？ 一応やりたいとおりに動いてはくれていますが… すこし構文が長くなってしまったので、もう少し 短くできる（簡単に？）できますでしょうか？ また、間違い等ありましたら、ご指摘お願いします。
- 1380649874335
- ベストアンサー率35% (14/39)
No4で回答した者です。 変な回答になってしまいました。無視して下さい。 （すみません。）
お礼
質問にかいとうさせていただきましたので よろしくおねがいします。
- 1380649874335
- ベストアンサー率35% (14/39)
長文です。 ３点質問があります。 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）数値や日付以外が入力された場合はどうしたいと お考えですか？ 以上です。
お礼
ご回答ありがうございます。 1）日付や日数を求めるのに、ループ処理が必ず必要なのでしょうか？ ループ処理は必要ありませんが、複数列に対応したいと考えています。 2）いまいち仕様でよく分からない部分があります。 それぞのセル入力時の正しい仕様を教えて下さい。 ＜B1の入力時＞ [B2,B3共に空白の場合] =>計算しない [B2に日付があり、B3は空白の場合] =>B3にB2-B1日数を返す [B2が空白で、B3に数値がある場合] =>B2にB1からB3日後の日付を返す [B2に日付があり、B3に数値がある場合] =>B1+B2=B3になっていなければエラー ＜B2の入力時＞ [B1,B3共に空白の場合] =>計算しない [B1に日付があり、B3は空白の場合] =>B3にB2-B1日数を返す [B1が空白で、B3に数値がある場合] =>B2-B3日付を返す [B1に日付があり、B3に数値がある場合] =>B1+B2=B3になっていなければエラー ＜B3の入力時＞ [B1,B2共に空白の場合] =>計算しない [B1に日付があり、B2は空白の場合] =>B2にB1+B3日付を返す [B1が空白で、B2に日付がある場合] =>B1にB2-B3日付を返す [B1、B2共に日付がある場合] =>B1+B2=B3になっていなければエラー 3）数値や日付以外が入力された場合はどうしたいと お考えですか？ 入力規則で日付・日数の入力のみとします このように考えています。 どうぞよろしくお願いします。
- MARU4812
- ベストアンサー率43% (196/452)
古典的な鉄版の手法はフラグで最小限の範囲のみ処理を飛ばす。 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
お礼
ご回答ありがとうございます。 Me.Range("B1") = Me.Range("B2") - Me.Range("B3") - 1 のあとに Me.Range("B2") = Me.Range("B3") - Me.Range("B1") - 1 Me.Range("B3") = Me.Range("B2") - Me.Range("B1") - 1 を記述したのですが、 エラーが出てしまいました。 記述が間違っているのでしょうか？
- Tom-3
- ベストアンサー率32% (42/130)
更新セルのターゲットを確定して変更する方法でどうでしょうか？ 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
- ベストアンサー率54% (777/1415)
イベントを停止させたら如何でしょう。 プロシージャの最初と最後にに以下の 文を置けばよいと思います。 Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False ＝＝中略＝＝ Application.EnableEvents = True End Sub 途中でExit Sub しないでね。
お礼
ご回答ありがとうございます。 試してみたのですが、入力する順序等によっては 同じ結果になるみたいです。 「Worksheet_Change」でやるのが間違ってるのでしょうか…
関連するQ&A
- エクセルでデータ入力された日付と時間を自動入力する
A1をA2に、B1をB2に、C1をC2に･･･ A1に入力したらA2に更新日付が入るという様に行いたいのですが、 ---------------- Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim r As Range For Each r In Target If r.Column = 1 Then r.Offset(0, 1).Value = Format(Now, “yyyy/mm/dd”“ ”“hh:mm:ss”) End If Next r End Sub ---------------- これをどのように改編したらいいのでしょうか？
- ベストアンサー
- Excel（エクセル）
- 毎月とか隔週に連動して日付を変えたい
OKWAVEで質問してある程度出来が上がってきましたが、まだ解決できないところがあり、 ご指導下さい、 M列に０以上の数字が入力されたらA列の日付を変えたい B列の 毎日は ＋１日後 B列の 毎週は ＋７日後 つまり M1に０以上なら 5／5が表示できるようにしたい(＋１日後) M6に０以上なら 5／13が表示できるようにしたい(＋７日後) それが下記の計算式です。 ------------------------------------- エクセルのシート名タブを右クリックしてコードの表示－現れたシートに下記をコピー貼り付けています Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim h As Range Dim c As Long On Error Resume Next For Each h In Application.Intersect(Target, Range("M:M")) If h > 0 Then If Cells(h.Row, "B") = "毎日" Then c = 1 ElseIf Cells(h.Row, "B") = "毎週" Then c = 7 Else c = 0 End If Cells(h.Row, "A") = Cells(h.Row, "A") + c End If Next End Sub －－－－－－－－－－－－－－－－ ＜質問１＞ 毎月、隔月、隔週 は下記であってますか？どこに入れたら動作するのでしょうか？ ElseIf Cells(h.Row, "B") = "毎月" Then c = 30 Else c = 0 End If ElseIf Cells(h.Row, "B") = "隔月" Then c = 60 Else c = 0 End If ElseIf Cells(h.Row, "B") = "隔週" Then c = 14 Else c = 0 End If 投稿日時 - 2012-05-04 10:29:04
- ベストアンサー
- その他MS Office製品
- どこを修正すれば 日付が変わるのか？
先ほど、 http://okwave.jp/qa/q7454676.html の質問して サンプルにはきちんと作動することを確認しました。 そこで、サンプル版ではないものに手を加えても動作がうまくいきません private sub Worksheet_Change(byval Target as excel.range) dim h as range on error resume next for each h in application.intersect(target, range("C:C")) if h = "完了" then if h.offset(0, -1) = "毎日" then h.offset(0, -2) = h.offset(0, -2) + 1 elseif h.offset(0, -1) = "毎週" then h.offset(0, -2) = h.offset(0, -2) + 7 end if end if next end sub －－－－－－－－－－－－－ for each h in application.intersect(target, range("N:N")) と変更したのですが、動作しません。 どこを修正すれば、動作するでしょうか？
- ベストアンサー
- Visual Basic
- 日付を入れるとセルがおかしくなります。
http://okwave.jp/qa/q7495702.html 以前の質問で、空白になった行を詰めていくような マクロをおしえていただき、mt2008さんのコードを利用しているのですが、新たにB列に、C列に何かが入力されたら日付を挿入する以下のマクロをいれました。 Private Sub worksheet_change(ByVal Target As Excel.Range) Dim h As Range On Error Resume Next For Each h In Application.Intersect(Target, Range("C:C")) If h <> "" Then Cells(h.Row, "B") = Date End If Next End Sub このマクロはちゃんと動いたのですが、実はここで困ったことが発生しました。空白行を詰めた時、 日付が詰めた日付に更新されてしまうのです。これは、B列の文字列が変わるのでしょうがない現象なのですが、詰める時に、どうしても日付だけはそのままにして上に詰めたいのです。 そんなことは可能でしょうか・・
- ベストアンサー
- オフィス系ソフト
- エクセル 数値結果の値によって日付を入れたい
シート2の2列目にOKが入ると、シート１のC列にOKが入り、更新された日がB列に表示されるようにしたいです。 C列に手入力でOKと入力すればB列に日付が表示されるのですが、C列をVLOOKで呼ぶようにしたら表示されなくなってしまいました。 どのように修正していいのか分かりません。 お教えいただければと思います。よろしくお願いいたします。 Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Range Dim TgRng As Range Set TgRng = Intersect(Range("C1:C2000"), Target) If Not TgRng Is Nothing Then Application.EnableEvents = False For Each Rng In TgRng If Rng.Value = "OK" Then Rng.Offset(, -1).Value = Date End If Next Application.EnableEvents = True End If Set TgRng = Nothing End Sub
- ベストアンサー
- Excel（エクセル）
- 日付入力マクロ
On Error Resume Next Dim r As Range Dim flg As Long flg = 0 If Intersect(Target, Range("A4:A600,E4:E600,J4:J600")) Is Nothing Then Exit Sub 'A列のみを対象 最初につなげるところ ActiveSheet.Unprotect flg = 1 For Each r In Target Dim a As Long Dim b As String With r If Not .NumberFormatLocal = "ge.m.d" Or .Value = "" Then .NumberFormatLocal = "G/標準" 'セルの書式設定がH00.m.d形式だったら標準に戻す 'セルが 数字 且 整数 且 101以上 且 991231以下 の場合 If IsNumeric(.Value) And Int(.Value) = .Value And .Value >= 19010101 And .Value <= 20991231 Then b = Left(.Value, 4) & "/" & Mid(.Value, 5, 2) & "/" & Right(.Value, 2) If IsDate(b) Then 'もしbがDateの形なら .Value = CDate(b) 'データ型を日付にする 'ここにつなげる。 変数はtmpからbに直す .NumberFormatLocal = "ggg" & _ IIf(Format(b, "e") > 9, "e年", "_0e年") & _ IIf(Month(b) > 9, "m月", "_1m月") & _ IIf(Day(b) > 9, "d日", "_1d日") ActiveSheet.Protect End If End If End With Next End Sub 上記のマクロで20090731と入力すると平成21年7月31日と表示されます。 210731を入力して平成21年7月31日と表示されるようにすることは可能ですか？
- ベストアンサー
- オフィス系ソフト
- 日付を増やすのは無理なのでしょうか？
いろいろ指導していただき 解決したと思ったらまた振り出しに戻ってしまいました。 N3が終了と表示されたら A列に 5／3が表示できるようにしたい(＋１日後) B列が毎週なら、A列は(＋７日後)を表示したい 現在 下記のような計算式が入っているのですが、動作しません。 その理由として、 N列には=IF(I1>0,"終了","未着手") B列は プルダウンで =$B$8:$B$9から選ぶようにしています つまり、I列によって 自動的に、終了か、着手が決まっています。 B列は私が手動でプルダウンで２つのいずれかを選んでいます。 このような計算式が入っていると下記のやり方では無理らしいのですが 結局 マクロを使う以外日付を増やすのは無理なのでしょうか？ そしてマクロを使うには、数式が入っていると作動しないのでしょうか？ －－－－－－－－－－－－－ エクセルのシート名タブを右クリックしてコードの表示－現れたシートに下記をコピー貼り付けています Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim h As Range On Error Resume Next For Each h In Application.Intersect(Target, Range("N:N")) If h = "終了" Then If h.Offset(0, -12) = "毎日" Then h.Offset(0, -13) = h.Offset(0, -13) + 1 ElseIf h.Offset(0, -12) = "毎週" Then h.Offset(0, -13) = h.Offset(0, -13) + 7 End If End If Next End Sub
- ベストアンサー
- オフィス系ソフト
- Excel VBA 入力規則
入力規則を利用して、３つのセルを連携させることを考えていますが、 不適合な値を張り付けらられた場合に拒否をする方法があるのでしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim ad As String Dim ma As Range Dim ma2 As Range Dim r As Range Dim r2 As Range Dim r3 As Range Dim r1 As Range Dim m As Long Dim m2 As Long Application.EnableEvents = False If Target = "" Then Range("F7").Validation.Delete Range("F7") = "" If Target.Address(0, 0) = "B7" Then Range("D7").Validation.Delete Range("D7") = "" End If GoTo EXIT_SUB End If With Worksheets("Sheet1") ad = "A4" Set r = .Range(ad) Set ma = r.MergeArea Set r1 = r.Offset(0, 1) m = Application.Match(Range("B7"), .Range(r1, .Cells(r.Row + ma.Count - 1, r1.Column)), 0) Set r2 = .Cells(r.Row + m - 1, r1.Column) Set ma2 = r2.MergeArea If Target.Address(0, 0) = "B7" Then If ma.MergeCells Then setValiS Target.Offset(0, 2), r2 Range("F7").Validation.Delete Target.Offset(0, 2) = "" Target.Offset(0, 4) = "" Else MsgBox "A列が連結されていません。" End If ElseIf Target.Address(0, 0) = "D7" Then Set r3 = r2.Offset(0, 1) m2 = Application.Match(Target, .Range(r3, .Cells(r2.Row + ma2.Count - 1, r3.Column)), 0) setValiS Target.Offset(0, 2), .Cells(r2.Row + m2 - 1, r3.Column) Target.Offset(0, 2) = "" End If End With EXIT_SUB: Application.EnableEvents = True End Sub Sub setVali2() Dim tc As Range Dim c As Range Set tc = Worksheets("登録").Range("D3") Set c = Worksheets("Sheet1").Range("C3") setValiS tc, c End Sub Sub setValiS(tc As Range, c As Range) Dim ss As String Debug.Print tc.Address, c.Address ss = getChildren(c) If ss > "" Then With tc.Validation .Delete .Add Type:=xlValidateList, Formula1:=getChildren(c) End With End If Worksheets("登録").Activate End Sub Function getChildren(c As Range) Dim c1 As Range Dim ss As String Dim s1 As String Worksheets("Sheet1").Activate ss = "" For Each c1 In c.MergeArea s1 = c1.Offset(0, 1) If s1 <> "" Then ss = ss & "," & s1 Next c1 If ss <> "" Then ss = Mid(ss, 2) Else MsgBox "データがありません！" End If getChildren = ss End Function Sub Outline() Dim CheckRow As Long Dim Moji As String Dim TopRow As Long Dim EndRow As Long With ActiveSheet .Range("A2").ClearOutline .Outline.SummaryRow = xlAbove CheckRow0 = .Range("A" & .Rows.Count).End(xlUp).Row CheckRow = CheckRow0 Do If Moji = "" Then Moji = .Cells(CheckRow, 1).Value EndRow = CheckRow ElseIf yy_mm(CDate(.Cells(CheckRow, 1).Value)) = yy_mm(CDate(Moji)) Then TopRow = CheckRow If TopRow = 1 Then .Rows(TopRow + 1 & ":" & EndRow).Rows.Group Exit Do End If Else .Rows(TopRow + 1 & ":" & EndRow).Rows.Group CheckRow = CheckRow + 1 Moji = "" End If CheckRow = CheckRow - 1 Loop Until CheckRow = 1 .Rows(CheckRow + 1 & ":" & EndRow).Rows.Group .Outline.ShowLevels RowLevels:=1 ExecuteExcel4Macro "SHOW.DETAIL(1," & CheckRow0 & ",TRUE)" End With End Sub Function yy_mm(d As Date) yy_mm = Format(d, "yy/mm") End Function
- 締切済み
- その他（プログラミング・開発）
- エクセル ダブルクリックで処理日の入力
お世話になります。 先般、お教え頂きました別のダブルクリックイベントプロシージャと 下記の当日の日付を入力するという処理を同じシート上で行いたいのですが、ＶＢエディターにどのように記述したら良いかわかりません。 当方、かなりの初心者です。 よろしくご教授くださいませ。 【新しく加えたい処理】 Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Range("b4:C999")) Is Nothing Then Exit Sub If ActiveCell = "" Then ActiveCell = Date Cancel = True End If End Sub 【もともと使っている処理】 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Range("h1:h999")) Is Nothing Then With Target If .Value = "" Then .Value = "有" ElseIf .Value = "有" Then .Value = "無" ElseIf .Value = "無" Then .Value = "" End If End With ElseIf Not Intersect(Target, Range("i1:i999")) Is Nothing Then With Target If .Value = "" Then .Value = "要" ElseIf .Value = "要" Then .Value = "不要" ElseIf .Value = "不要" Then .Value = "" End If End With End If End Sub よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルVBAで重複入力の排除
すでに入力規則はリストで使用しております。 そのためVBAで重複入力の排除を行おうと思います。 一応以下のコードでできたのですが、もっと良い方法があったら教えてください。 お願いいたします。 Private Sub Worksheet_Change(ByVal Target As Range) Dim myDic As Object Dim c As Variant, varData As Variant Dim i As Long If Application.Intersect(Target, Range("A1:A50")) Is Nothing Then Exit Sub Set myDic = CreateObject("Scripting.Dictionary") varData = Range("A1:A50").Value For Each c In varData If Not c = Empty Then i = i + 1 If Not myDic.Exists(c) Then myDic.Add c, Null End If End If Next If myDic.Count < i Then MsgBox Target & " は重複！" Application.EnableEvents = False Application.Undo Application.EnableEvents = True End If End Sub
- ベストアンサー
- Excel（エクセル）
お礼
ご回答ありがとうございます。 返信が遅くなってすいません。 とてもご丁寧にご回答いただき とても感謝しています。 ありがとうございます！ ============================ '1行目の変更時の処理 '2行目の変更時の処理 'ここは3行目をベースで。 ============================ については If StrComp(line, "1") = 0 Then If Range(rngAlph + "2") > 0 Then Range(rngAlph + "3") = Range(rngAlph + "2") - Range(rngAlph + "1") + 1 ElseIf Range(rngAlph + "3") > 0 Then Range(rngAlph + "2") = Range(rngAlph + "1") + Range(rngAlph + "3") - 1 Else Range(rngAlph + "3") = "" End If End If If StrComp(line, "2") = 0 Then If Range(rngAlph + "1") > 0 Then Range(rngAlph + "3") = Range(rngAlph + "2") - Range(rngAlph + "1") + 1 ElseIf Range(rngAlph + "3") > 0 Then Range(rngAlph + "1") = Range(rngAlph + "2") - Range(rngAlph + "3") + 1 Else Range(rngAlph + "1") = "" End If End If 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 と記述しました。 ＞目的は、仕様通りに動かしたい事でしょうか。それとも、勉強等や仕事で活かしたいのでしょうか。 目的は仕事で活かしたいと考えています。 ＞一応やりたいとおりに動いてはくれていますが… 計算については問題なく思い通りにできるようになりました！ ただB1～B3が入力済みの状態で、B1をDELETEすると、 当然B3が「B2-B1(0)」で計算され、その直後B3をDELETEすると B1が「B2-B3(0)」で計算されてしまい、3つのセルを同時にDELETE しない限り、永遠と計算されてしまうという状態になってしまいます。 「一応」という表現はこのことを言いたかったのですが、 表現が悪かったと反省しています。すいません。