エクセルで日付と時間を自動入力する方法
- エクセルでデータ入力された日付と時間を自動的に入力する方法について教えてください。
- 特定のセルに入力した日付と時間が、他のセルに自動的に反映されるようにしたいです。
- VBAを使用して、エクセルの特定のセルに入力した日付と時間を他のセルに自動的に入力する方法を教えてください。
- ベストアンサー
エクセルでデータ入力された日付と時間を自動入力する
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 ---------------- これをどのように改編したらいいのでしょうか？
- simizuchi
- お礼率57% (4/7)
- Excel（エクセル）
- 回答数5
- ありがとう数2
- みんなの回答 （5）
- 専門家の回答
質問者が選んだベストアンサー
元は入力が一列目対象でしたが、それを元のコードのまま一行目を対象に変更したいのでしたら Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim r As Range Application.EnableEvents = False For Each r In Target If r.Row = 1 Then r.Offset(1, 0).Value = Format(Now, “yyyy/mm/dd”“ ”“hh:mm:ss”) End If Next r Application.EnableEvents = True End Sub For Each～Nextが不要な気もしますが… もし不要でしたら Private Sub Worksheet_Change(ByVal Target As Excel.Range) Application.EnableEvents = False If Target.Row = 1 Then Target.Offset(1, 0).Value = Format(Now, "yyyy/mm/dd"" ""hh:mm:ss") End If Application.EnableEvents = True End Sub
その他の回答 (4)
- kkkkkm
- ベストアンサー率65% (1618/2457)
No.3の補足です。 現状だとデータを削除した時にも更新日付が変更されます。 もし、削除したときは変更したくないのでしたら 前者だと If r.Row = 1 Then を If r.Row = 1 And r.Value <> "" Then 後者だと If Target.Row = 1 Then を If Target.Row = 1 And Target.Value <> "" Then に変更してください。
お礼
ありがとうございます。 完璧です。
- hi-ball
- ベストアンサー率0% (0/1)
こんな感じどうでしょう？ Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Integer For c = 1 To 3 If Target.row = 1 And Target.Column = c Then Cells(Target.row, Target.Column).Offset(1).Value = Format(Now, "yyyy/mm/dd"" ""hh:mm:ss") End If Next End Sub
- imogasi
- ベストアンサー率27% (4737/17068)
Sheet1限定としてよいだろう、そのシートモジュールに Private Sub Worksheet_Change(ByVal Target As Range) Target.Offset(0, 1) = Now End Sub でどうか？これで正しいとは思わないが。こんな質問のニーズは想像しにくいから。 Ｔａｒｇｅｔセル（A1,B1,C1など、入力するセル）の場所に何か限定でもあると思うが、質問が不明確ではないか？ 書式に注文はあるか？ など後続の回答のために、補足しておいたらどうかな？
補足
A1に入力したらA2に入力日付を自動表示（更新含む）させる B1に入力したらB2に入力日付を自動表示（更新含む）させる 以下、CDE・・・というVBAです。 書式に注文はありません。
- hi-ball
- ベストアンサー率0% (0/1)
A1を入力したらA2に更新日付なら下記みたいな感じです。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.row = 1 And Target.Column = 1 Then Cells(Target.row, Target.Column).Offset(1).Value = Format(Now, "yyyy/mm/dd"" ""hh:mm:ss") End If End Sub
補足
すいません。 これだとA1に入力したらA2に反映はされますが、 B1に入力したらB2に反映されません。 初心者ですいません。
関連するQ&A
- エクセルでデータ入力された日付と時間を自動入力する
前回ご質問にて 1行目に何か入力したら2行目に日付と時間を自動入力する というVBAを教えて頂きました。 ------------------------ Private Sub Worksheet_Change(ByVal Target As Excel.Range) Application.EnableEvents = False If Target.Row = 1 Then Target.Offset(1, 0).Value = Format(Now, "yyyy/mm/dd"" ""hh:mm:ss") End If Application.EnableEvents = True End Sub ------------------------ これを1行目に何か入力したら2行目に日付と時間ではなく セル指定を行いたいのです。 例）F13～P13に何か入力したら、その下のセルの F14～P14に日付と時間が自動入力される という作りです。 よろしくお願いします。
- ベストアンサー
- Excel（エクセル）
- エクセルで日付と時間を自動入力する
エクセルでF13～P13に何か入力したら、その下のセルの F14～P14に日付と時間が自動入力される という質問、回答を見つけました。 これで日付を削除するかどうかのメッセージボックスを出さずに 入力するセルのデータを削除した時に日付も削除するには どの部分を削除すれば良いですか？ Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim mRng As Range Application.EnableEvents = False For Each mRng In Target If Not Intersect(mRng, Range("F13:P13")) Is Nothing Then If mRng.Value = "" Then If MsgBox("日付も削除しますか？", vbYesNo + vbDefaultButton2) = vbYes Then mRng.Offset(1, 0).Value = "" End If Else mRng.Offset(1, 0).Value = Format(Now, "yyyy/mm/dd"" ""hh:mm:ss") End If End If Next mRng Application.EnableEvents = True End Sub
- ベストアンサー
- Excel（エクセル）
- 日付の自動表示がうまくできません。
VBAを使って、EXCELで日付を自動表示するマクロを作ったのですが、うまく動作しません。 設定の条件は、（対象の行は６～３１行目で） Ｄ列に入力があった場合、Ｇ列に日付を表示、 Ｍ列に入力があった場合、Ｎ列に日付と時間を表示 です。 Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Integer, c As Integer 'r 行番号 'C 列番号 r = Target.Row c = Target.Column If Target.Count > 1 Then Exit Sub If c <> 13 Or r < 6 Or r > 31 Then End If Cells(r, c) <> "" Then If c = 13 Then Cells(r, c + 1) = Format(Now, "m/d hh:mm") Else Cells(r, c + 1) = "" End If If Target.Count > 1 Then Exit Sub If c <> 4 Or r < 6 Or r > 31 Then End If Cells(r, c) <> "" Then If c = 4 Then Cells(r, c + 3) = Format(Now, "m/d hh:mm") Else Cells(r, c + 3) = "" End If End Sub 作っているうちに、どこがおかしいのかわからなくなってしまいました。 助けて頂ければと思います。
- ベストアンサー
- Visual Basic
- Excelで入力日の自動入力日を格納するには
入力日を自動入力して、その日付を格納します。 さらに、隣のセルにコピーして入力日で並べ替えをしたいのですが 並べ替えが出来ません。 (1)A2～A10に何か入力したら、B列に入力日を返します。 Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Integer, c As Integer 'r 行番号 'C 列番号 r = Target.Row c = Target.Column If c <> 1 Or r < 2 Or r > 10 Then End If Cells(r, c) <> "" Then Cells(r, c + 1) = Format(Now, "yyyy/m/d") Else Cells(r, c + 1) = "" End If End Sub 上記で、入力日を格納するところまでは出来ました。 (2)続いてマクロ【並べ替え】で、A2－B10をコピーし、E2へ貼り付け、 日付降順で並べ替えをします。 Sub 並べ替え() Range("A2:B10").Select Selection.Copy Range("E2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Columns("E:F").Select Selection.Sort Key1:=Range("F2"), Order1:=xlDescending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin, DataOption1:=xlSortNormal Range("F2").Select End Sub (3)上記マクロをコマンドボタンに貼り付けましたが、 貼り付けまではいきましたが、並べ替えができませんでした。 コードで並べ替え制限などかかってるのでしょうか？？ よろしくお願い致します。
- ベストアンサー
- オフィス系ソフト
- ＥＸＣＥＬマクロでのシート間のデータ同期方法
質問させていただきます。 ＥＸＣＥＬにて、"シート１"のA1～C3と"シート２"のD4～F6を 同期化したく考えております。 ・いわゆる一方のシートが「読み取り専用」になってしまうリンク貼り付けではなく、シート1、シート2相互が書き換え可能の同期化です。 ・A1とD4、B3とE6、のように互いに照合箇所のセル同士を同期反映させたいと考えております。 なお、他の質問を参照したところ、 シート１のA1とシート２のD4の単一セルを同期かする方法は確認できました。（以下参照） ***************************************************************** シート１のコードは Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$1" Then Worksheets("シート２").Range("D4") = Target End If End Sub シート２のコードは Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$D$4" Then Worksheets("シート１").Range("A1") = Target End If End Sub *************************************************************** これを参考にVBAの シート１のコードエディターに Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$2" Then Worksheets("シート２").Range("D5") = Target End If End Sub シート２のコードエディターに Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$D$5" Then Worksheets("シート２").Range("A2") = Target End If 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
- 締切済み
- その他（プログラミング・開発）
- 日付入力と日数計算
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』なので当然なのですが…） どうすればうまくいくか、ご教示お願いいたします。 また、この計算を複数列で行いたいので、それもあわせて 教えていただけると幸いです。 よろしくお願いします。
- ベストアンサー
- Visual Basic
- エクセルＶＢＡについて
http://okwave.jp/qa/q7236213.html 上記質問の発展形なのですが 同様のことを Ｅ列に日付 Ｆ列に売上 Ｇ列に結果 でやりたいのですが この時Ａ列～Ｃ列のマクロも残したままでしたいのですが 下記のように同様のプロシージャーを下段に書けばできると思ったのですが うまくいきません。 Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$A$1" Then Exit Sub If Target = "" Then Exit Sub Range("C10:C65536").ClearContents With Range(Cells(9 + Range("A1").Value, "C"), Cells(Range("A65536").End(xlUp).Row, "C")) .FormulaR1C1 = "=MAX(RC2:R[" & -Range("A1").Value + 1 & "]C2,FALSE)" .Value = .Value End With End Sub Private Sub worksheet_change(ByVal Target As Excel.Range) If Target.Address <> "$E$1" Then Exit Sub If Target = "" Then Exit Sub Range("G10:G65536").ClearContents With Range(Cells(9 + Range("E1").Value, "G"), Cells(Range("E65536").End(xlUp).Row, "G")) .FormulaR1C1 = "=MAX(RC6:R[" & -Range("A1").Value + 1 & "]C6,FALSE)" .Value = .Value End With End Sub どなたかお知恵を拝借できませんでしょうか？
- ベストアンサー
- オフィス系ソフト
- エクセルマクロで値入力時に時間が自動入力できる
あるセルに値が入力されたら、 他の場所にその時間が入力されるような エクセルマクロを作りたいと考えています。 インターネットで調べて 下記の様にして1ヵ所だけは入力できるようになりました。 '時間の自動入力 Private Sub Worksheet_Change(ByVal Target As Range) 'Dim k As Long 'i = 9 If Intersect(Target, Range("C8")) Is Nothing Then Exit Sub Else d2 = Time Range("G8").Value = d2 End If End Sub 上記のマクロだと C8固定になってしまうので、 C8～C100で 上から順番に入力したときに それぞれの入力時に動作するように 変更したいと考えています。 そこで変数を設定し、ifで1つづつ変数を増やす処理を入れる前に 実験的に以下の様に書き換えてみたのですが、 Dim i As Long i = 9 If Intersect(Target, Cells(9, 3)) Is Nothing Then 動作しませんでした。 インターネット上に載せてくれている方の情報では range用 みたいなことを書いてあるのを見たのですが、 やはりこの方法ではうまくいかないでしょうか？ よろしくお願いします。
- ベストアンサー
- Visual Basic
- データ更新時の処理について（エクセルＶＢＡ）
セルＡ２に数字の６６が入っているとして、セルＡ２を６７に更新した瞬間に６７－６６という処理をさせたいのですが、下記の？？？の部分が分かりません。どなたか、教えてください。お願いします。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$2" Then ？？？ End If End Sub
- ベストアンサー
- オフィス系ソフト
お礼
ありがとうございます。 できました。