ExcelのVBAについて(再掲)

質問

ExcelのVBAについて(再掲)

以下のシートは作成中(勉強中)のものです。いずれは私的に実用しようと思っています。。

さて、質問ですが、「シート1のA3に入力、手動でシート2に移動自動で転記し、手動でシート1に移動し、また入力する」という単純動作を目的に作成しています。問題点は沢山ありますが、例えば『シート1の時間列が何かの変更で書き換えられてしまう』、『沢山書いていくと分かりますが、途中で行削除を行うと、時間列に削除行分の時間記録が下向きに書き込まれる』などです。他にもあると思っていますが、(1)この問題はなぜ発生するのか？(2)修正案としてはどの様な例があるか？
等をお聞きしたいです。細々と問題はあると思っていますので、その様な問題点もお聞きしたいです。

よろしくお願いします！

'///Sheet1///

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim time7 As Range
For Each time7 In Target
If time7.Column = 1 Then
time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _
Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM")
Application.EnableEvents = False
Application.EnableEvents = True
End If
Next time7

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value

End Sub

Private Sub Worksheet_Activate()
Application.Goto ActiveSheet.Range("A3"), True
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Sheet1").Range("H3").Select
ActiveCell.FormulaR1C1 = "5"
Sheets("Sheet1").Range("E3").Select
Selection.ClearContents

Dim str_Left As String

'セルE4に文字列、セルH4に数字を予め入れておくこと。
str_Left = Left(Cells(4, 5), Cells(4, 8))

MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!"

Sheets("Sheet1").Range("A3").Select

End Sub

' ///Sheet2///

Private Sub Worksheet_Activate()

Application.Goto ActiveSheet.Range("A3"), True
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Sheet2").Range("A3").Select

End Sub

回答No.3

kkkkkm · ベストアンサー

No1の一部訂正と補足
Cells(にシート指定がなかったので以下のように訂正してください。
str_Left = Left(ws1.Cells(4, 5), ws1.Cells(4, 8))
MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!"
ws1.Range("A3").Select
ws2.Activate
シート2を表示したい場合はws2.Activateを上記の所に付加してください。

補足

ありがとうございます。単純明快というか理想のコードです^^

作成中な為に敢えてそのまま使えるのは使います。

後日参考にします！

'///Sheet1///

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim time7 As Range
For Each time7 In Target
If time7.Column = 1 Then
time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _
Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM")
Application.EnableEvents = False
Application.EnableEvents = True
End If
Next time7
'(1)シートを変数にセット
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

'(2)シートを指定してデータを転記
ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value

End Sub

Private Sub Worksheet_Activate()
'
' 新規行挿入
'

'
Worksheets("Sheet2").Range("3:3").Insert

Application.Goto ActiveSheet.Range("A3"), True
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Sheets("Sheet1").Range("H3").Select
ActiveCell.FormulaR1C1 = "5"
Sheets("Sheet1").Range("E3").Select
Selection.ClearContents

Dim str_Left As String

'セルE4に文字列、セルH4に数字を予め入れておくこと。
str_Left = Left(Cells(4, 5), Cells(4, 8))

MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!"

Sheets("Sheet1").Range("A3").Select

End Sub

' ///Sheet2///

Private Sub Worksheet_Activate()

'(1)シートを変数にセット
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

ws1.Activate

End Sub

回答No.4

kkkkkm

> (1)この問題はなぜ発生するのか？

A列に変更があったら
time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _
Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM")
が実行されるからです。ので、A3変更限定動作にしました。

またシート1及びシート2の
Worksheet_Activate
で何も制御していないのでシートを移動するたびに行挿入になっています。多分それはまずいと思います。

補足

前者は優れた考えですね。後者は実はまだ思案してて、今あるシートに更にシート3群を作れないか、、。そして、シート3以降を見た場合に閲覧記録と明記できないか悩んでいます。ハードルを上げてしまいすみません。
参考になります、ありがとうございます^^

回答No.2

kkkkkm

No1の補足です。

実行中になにがしかのエラーで止まった場合Changeイベントが無効のままになっている可能性がある(A3にデータを入れても反応しないなど)のでイミディエイトウィンドウに
Application.EnableEvents = True
と記載してエンターしてください。

回答No.1

kkkkkm

> シート1のA3に入力、手動でシート2に移動自動で転記し、手動でシート1に移動し、また入力する

シート1のA3に入力したらシート2自動で転記し(移動はしない)確認メッセージを出しシート1のA3に再度入力できるようにする。入力は常時シート1のA3である。シート1のA3以外の入力では何も起こらない。
Private Sub Worksheet_Activate()
はシート1、シート2とも不要です。

以下のような感じでいかがですか。

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim str_Left As String

Application.EnableEvents = False

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

If Target.Address = ws1.Range("A3").Address Then
Target.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _
Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM")
ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value
Application.Goto ws2.Range("A3"), True
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Application.Goto ws1.Range("A3"), True
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ws1.Range("H3").Value = "5"
ws1.Range("E3").ClearContents
'セルE4に文字列、セルH4に数字を予め入れておくこと。
str_Left = Left(Cells(4, 5), Cells(4, 8))
MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!"
ws1.Range("A3").Select
End If

Set ws1 = Nothing
Set ws2 = Nothing

Application.EnableEvents = True

End Sub