ExcelのVBAについてです。シート1と2を作成

質問

ExcelのVBAについてです。シート1と2を作成し、シート1にバーコードまたはキーボードで入力します。シート1は入力専用かつ入力した分の早見表で、実際にはシート2に転記仕訳して、シート3以降に表を作成したいです。使い方はシート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")
End If

Application.EnableEvents = False

Application.EnableEvents = True

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

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

Dim se_r As String
se_r = Application.InputBox("バーコードを入力してください")
Select Case se_r
Case "False"
MsgBox "キャンセルされました"
Case ""
MsgBox "空欄が入力されました"
Case Else
Range("A3").Value = se_r
End Select

End Sub

' ///Sheet2///

Private Sub Worksheet_Activate()

Dim Emp(1 To 300) As String
Dim msg As String
Dim i, i2, Cnt As Integer
Dim N_In As Variant

For i = 3 To 3
If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定
Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理
End If

'(1)シートを変数にセット
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim st1, s, i3 As Long
Dim Bst As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

'(2)シートを指定してデータを転記

st1 = ws1.Cells(Rows.Count, "E").End(xlUp).Row 'A列の最終行を設定する
s = 3
For i3 = 3 To st1

Set Bst = ws2.Columns("E").Find(What:=ws1.Cells(i3, "E"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
シート間のE列を比較

If Bst Is Nothing Then '比較して無い場合は、下記を実行
ws1.Cells(s, "A") = ws1.Cells(i3, "A") '追加する文字を転記する。（コード）
s = s + 1

End If

Next i3

Next i

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

ws1_.Activate

End Sub

回答No.1

kkkkkm · ベストアンサー

Sheet1のWorksheet_Change

For Each time7 In Target
これ不必要だと思います。
A列を全てもしくはすべてのセルを選択してDeleteキーを押してみてください。ほとんど暴走状態になります。

A列の変更をそのままにしたいのでしたらセルは1個だけ選択もしくは変更として

If Target.Column = 1 And Target.CountLarge = 1 Then
Target.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _
Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM")
End If

Application.EnableEvents = False
Application.EnableEvents = True
連続で入れても無意味です。 スイッチオフにしてすぐオンにしています。
プロシージャの最初にFalseで最後にTrueでいいのではないですか。

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

Worksheet_Activateで無条件でH3に5をセットしてるので、InputBoxでキャンセルしようが空欄だろうが無関係にSheet2のH列に5が追加されていきます。そのような仕様ならいいですが。

Sheet2のWorksheet_Activate()

Dim ws1_ As Worksheet
Set ws1_ = Worksheets("Sheet1")

前に
Set ws1 = Worksheets("Sheet1")
があるのだからws1を使えばいいと思いますが何故に？

Application.EnableEvents = False
For i = 3 To 3
If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定
Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理
End If
Application.EnableEvents = True

としておかないと行挿入で無意味なWorksheet_Changeが実行されます。

変数宣言を最初に固めておくと
Worksheets("Sheet1")はws1ですみます。
3 to 3 なら Forする必要はありません。

ws1.Cells(s, "A") = ws1.Cells(i3, "A")

これの意味が分からないので、これでいいのかどうかわかりません。

Set ws1 = Worksheets("Sheet1")
などのようにSetをした場合、利用しなくなった時点で
Set ws1 = Nothing
のように開放する癖をつけておいた方がいいです。

シートを移動しなくても同じことができますが、何故移動させるのか不明です。

お礼

いつも回答ありがとうございます。暴走する兼ですが、VBEにて中断したのちにセル値を消したりしていますので気付きませんでした^^;
要らないかどうかと言われると、モジュール的に組み入れる際に検証してませんから、要らないと言えばそうなると思います。できるだけ有効に活用して知識にしたい思いです。。

意味が分からない部分は頭の部分がws1後ろがws1ですが、頭の部分は書き込み部分なのでws2になります。後ろはそのまま。書いたり戻したりしてるので間違ってしまいました。

開放につきましては現在進行中です。ありがとうございます^^

補足

シート2を一部修正してみました。宣言部分はまだまとめていません。おっしゃいのとは程遠いかも知れませんね。

' ///Sheet2///

Private Sub Worksheet_Activate()

Dim Emp(1 To 300) As String
Dim msg As String
Dim i, i2, Cnt As Integer
Dim N_In As Variant

For i = 3 To 3
If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定
Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理
End If
Application.EnableEvents = True

'(1)シートを変数にセット
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim st1, s, i3 As Long
Dim Bst As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

'(2)シートを指定してデータを転記

st1 = ws1.Cells(Rows.Count, "E").End(xlUp).Row 'A列の最終行を設定する
s = 3
For i3 = 3 To st1

Set Bst = ws2.Columns("E").Find(What:=ws1.Cells(i3, "E"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
'A列とE列を比較

If Bst Is Nothing Then '比較して無い場合は、下記を実行
ws2.Cells(s, "A") = ws1.Cells(i3, "A") '追加する文字を転記する。（コード）
s = s + 1

End If

Next i3 'A列データの最終行までループ

Next i

ws1.Activate

Set ws1 = Nothing
Set ws2 = Nothing

End Sub