VBA 表作成で内容を最下行で入力した場合 自動で次の行の作成を行いたい。

質問

VBAで質問です。　　Excel2003

最下行を検索し、そこの内容部分を入力された場合、1行あたらしく
式、罫線をコピーしたいのですがずっとループを起こしてしまいます。
直し方を教えていただきたいです。

ソース
Private Sub Worksheet_Change(ByVal Target As Range)
'------------------------------------
'変数の宣言
'------------------------------------
Dim naiyou As Object
Dim bikou As Object
Dim xline As Integer
Dim yline As Integer
Dim count As Integer
Dim startrow As Integer
Dim maxcolumn As Integer

'------------------------------------
'内容＝D4の列検索
'------------------------------------
Set naiyou = ActiveSheet.Cells.Find("内容")
xline = naiyou.Column

'------------------------------------
'表示している最終行の検索
'------------------------------------
startrow = 4
count = Cells(startrow, xline).End(xlDown).Row
'------------------------------------
'備考の＝I4列検索
'------------------------------------
Set bikou = ActiveSheet.Cells.Find("備考")
yline = bikou.Column

'------------------------------------
'コピペ処理
'------------------------------------
If ActiveSheet.Cells(count, 4) <> "" Then
Range(Cells(count + 1, 1), Cells(count + 1, yline)).Select
Selection.Copy
Range(Cells(count + 2, 1), Cells(count + 2, yline)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Exit Sub
Else:
End If
End Sub

回答No.6

mitarashi · ベストアンサー

#5です。
キーイベントが生きたままファイルを閉じるとやっかいなので、
標準モジュールに
Sub Auto_Close()
resetEnterEvent
End Sub
を入れておいて下さい。

回答No.5

mitarashi

>その場合、variantで宣言してどうすればよろしいでしょうか？
意味不明ですが、Enterキー割り込みに作り替えてみました。数値が変わらずとも、空でもEnterを押せば動作します。（矢印キーとかで移動しても無効です）解説はいたしかねます。元のコードを生かしたので冗長です。他のシートから、目的のシートに移らないと、イベントが有効になりません。また、Sheet4が対象のコードになっています。
＜シートモジュール＞
Public Sub Enter_keyin(ByVal target As Range)
Dim myRange As Range, headerRange As Range
Dim lastRow As Long
Const CheckColumn As String = "D"

Set headerRange = Range("A4:I4") '見出し行の範囲
If target.Cells.Count <> 1 Then Exit Sub
If target.Column <> Range(CheckColumn & "1").Column Then Exit Sub
If target.Row <= headerRange.Row Then Exit Sub
lastRow = ActiveCell.Row
Set myRange = headerRange.Offset(lastRow - headerRange.Row)
’次の行が空でなければ抜ける
If emptyCheck(myRange.Offset(1, 0)) Then
myRange.Copy myRange.Offset(1, 0)
'定数削除
On Error Resume Next
myRange.Offset(1, 0).SpecialCells(xlCellTypeConstants, 23).ClearContents
On Error GoTo 0
myRange.Offset(1, 0).Cells(1).Activate
End If
Set myRange = Nothing
End Sub

'選択範囲がすべて空かチェックする、ワークシート関数のCountA等でも良い
Private Function emptyCheck(target As Range) As Boolean
Dim myCell As Range
Dim emptyFlag As Boolean

emptyFlag = True
For Each myCell In target.Cells
If myCell.Value <> "" Then emptyFlag = False
Next myCell
emptyCheck = emptyFlag
End Function

'ワークシートがアクティブになったとき、Enterキー割り込みを有効化
Private Sub Worksheet_Activate()
Call setEnterEvent
End Sub
'無効化
Private Sub Worksheet_Deactivate()
Call resetEnterEvent
End Sub

＜標準モジュール＞
Sub ENTER_Key()
Dim myCell As Range

Set myCell = ActiveCell
Sheets("Sheet4").Enter_keyin myCell　’Sheet4が対象
End Sub

Sub setEnterEvent()
Application.OnKey "{RETURN}", "ENTER_Key"
Application.OnKey "{ENTER}", "ENTER_Key" 'テンキー
End Sub

Sub resetEnterEvent()
Application.OnKey "{RETURN}"
Application.OnKey "{ENTER}"
End Sub

回答No.4

mitarashi

#3です。
イベントの条件は、
a.複数セルでないこと（行、列全体選択でイベントが起こる事の防止）
b.指定列であること
c.最後に指定行であること
を3段階で見ています。最後に使っているIntersectは、この様なケースでよく使われるので無理矢理使ってみただけで、今回の事例では、
If Target.row = lastRow Then
で十分です。逆にIntersectを使っていれば、bは無くても動きます。
他には珍奇な関数は使っていませんし、ayamine0さんはオブジェクト変数も活用されているので、ご理解いただけるのではないかと思います。ただ、
Dim naiyou As Object
は、
Dim naiyou as Range
とされた方が、インテリセンスが効いて良いと思います。参考URLは検索してみつけました、ご参考まで。
http://shadowslasheizan.blog114.fc2.com/blog-entry-93.html

お礼

ありがとうございます！
出来ました。自分なりのプログラムで完成できました。

問題が出来まして、

内容入力をnullのまま次の行にした場合、改行されないのですが、
その場合、variantで宣言してどうすればよろしいでしょうか？

回答No.3

mitarashi

直接の回答ではありません。現金出納簿の行を増やすのに類似のニーズがあり、試しに作ってみました。イベントの条件判定や、Selectしない複写のご参考にはなるかもしれません。
ayamine0さんのコードを完全には読解していませんので、意図と異なるところがあるかもしれませんが、悪しからず。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range, headerRange As Range
Dim lastRow As Long
Const CheckColumn As String = "D"

Set headerRange = Range("A4:I4") '見出し行の範囲
If Target.Cells.Count <> 1 Then Exit Sub
If Target.Column <> Range(CheckColumn & "1").Column Then Exit Sub
Application.EnableEvents = False
lastRow = Range(CheckColumn & ActiveSheet.Rows.Count).End(xlUp).Row
Set myRange = headerRange.Offset(lastRow - headerRange.Row)
If Not Intersect(Target, Range(CheckColumn & lastRow)) Is Nothing Then
myRange.Copy myRange.Offset(1, 0)
'定数削除
myRange.Offset(1, 0).SpecialCells(xlCellTypeConstants, 23).ClearContents
myRange.Offset(1, 0).Cells(1).Activate
End If
Set myRange = Nothing
Application.EnableEvents = True
End Sub

補足

難しいですね。
イベントの判定条件、セレクトしない複写している部分など
コメントいれてもらえないでしょうか・・・

今自分なりに理解はしようとしてるのですが、自分のつかっていない
関数が多いもので。すいません。

回答No.2

imogasi

＃１のお礼の部分
Application.EnableEvents=False
と
Application.EnableEvents=True
はイベントプロシの入り口直ぐと
出口直前で入れるもの。後者は大丈夫ですか
それにApplication.EnableEvents=False
はその後の途中でエラーを起すと、再度Changeイベントが発生するべきときに、前のが残っておって、働かない。防止するエラー処理をちゃんとやればこんな話にならないが。
もし起こったら
別途
Sub test01()
Application.EnableEvents = True
End Sub
を標準モジュールに作って１回実行すべきだ。参考までに。
ーー
ChangeイベントはVBAで相当経験をつまないと難しいよ（どういう場合に使うべきかの場合も含めて）。

回答No.1

n-jun

Changeイベント
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_event.html#change
コピペする事でイベントが発生し続けてしまい、無限ループになるのでしょう。

コピペ処理のIf文を
Application.EnableEvents = False
'～コピペ
Application.EnableEvents = True
で挟んであげる。

補足

ありがとうございます。　しかし、
ループは終了できましたが、セルをほかのとこに移動しようとするとまた
かってにコピペが処理がはじまってしまい。結局
作業ができなくなってしまいます。

変更後
'------------------------------------
'コピペ処理
'------------------------------------
If ActiveSheet.Cells(count, 4) <> "" Then
Application.EnableEvents = False
Range(Cells(count + 1, 1), Cells(count + 1, yline)).Select
Selection.Copy
Range(Cells(count + 2, 1), Cells(count + 2, yline)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.EnableEvents = True

Else:
End If
Exit Sub