エクセルマクロの問題でお願いします。


E1セルにデーターが自動記入されると、5行目から下にデーターが追加するようになっています。
任意の行(仮に100行とします)まで書き込んだ以降は、常に最下行の100行目にデーターが書き込まれて、其れより上のデーターは1行ずつ繰り上がり、古いデーターは消去される、様にマクロを修正したいのですが、どのようにすれば良いでしょうか?

マクロ
Private Sub Worksheet_Change(ByVal Target As Range)

Const Target_Column = 5 ' E列
Const Start_Row = 5 ' E5 を開始
Const Input_Row = 1 ' E1 を入力

' E1 かどうか確認
If Target.Row <> Input_Row Or Target.Column <> Target_Column Then Exit Sub


Application.EnableEvents = False


If IsEmpty(Cells(Start_Row, Target_Column)) Then
Target_Row = Start_Row
ElseIf IsEmpty(Cells(Start_Row + 1, Target_Column)) Then
Target_Row = Start_Row + 1
Else
Target_Row = ActiveSheet.Cells(5, Target_Column).End(xlDown).Row + 1
End If

Cells(Target_Row, Target_Column).Value = Cells(1, Target_Column).Value
Cells(Target_Row, 2).Value = Cells(1, 2).Value
Cells(Target_Row, 3).Value = Cells(1, 3).Value
Cells(Target_Row, 4).Value = Cells(1, 4).Value

If Cells(Target_Row, Target_Column).Value <> "" Then
Target.Offset(Target_Row - 1, -4).Value = Date + Time
End If

Application.EnableEvents = True

End Sub

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2019/06/30 08:31:29
  • 終了:2019/07/05 17:00:53

ベストアンサー

id:Z1000S No.1

空腹おやじ回答回数37ベストアンサー獲得回数252019/07/05 16:34:27

やりたいのは、こんな事でしょうか?

Private Sub Worksheet_Change(ByVal Target As Range)

    Const Target_Column = 5 ' E列
    Const Start_Row = 5 ' E5 を開始
    Const Input_Row = 1 ' E1 を入力

    'ここで指定した行まで書き込む
    Const BOTTOM_ROW    As Long = 100

    Dim Target_Row  As Long

    ' E1 かどうか確認
    If Target.Row <> Input_Row Or Target.Column <> Target_Column Then Exit Sub


    Application.EnableEvents = False


    If IsEmpty(Cells(Start_Row, Target_Column)) Then
        Target_Row = Start_Row
    ElseIf IsEmpty(Cells(Start_Row + 1, Target_Column)) Then
        Target_Row = Start_Row + 1
    Else
        Target_Row = ActiveSheet.Cells(Start_Row, Target_Column).End(xlDown).Row + 1
    End If

    If Target_Row > BOTTOM_ROW Then
        '最下行より下になったら、先頭行を削除する
        Rows(Start_Row).Delete

        '書き込む行を最下行にする
        Target_Row = BOTTOM_ROW
    End If

    Cells(Target_Row, Target_Column).Value = Cells(1, Target_Column).Value
    Cells(Target_Row, 2).Value = Cells(1, 2).Value
    Cells(Target_Row, 3).Value = Cells(1, 3).Value
    Cells(Target_Row, 4).Value = Cells(1, 4).Value

    If Cells(Target_Row, Target_Column).Value <> "" Then
        Target.Offset(Target_Row - 1, -4).Value = Date + Time
    End If

    Application.EnableEvents = True

End Sub

BOTTOM_ROWより下にデータがない前提で処理しています。
先頭行の削除ではなく、先頭データ(Range)を削除したい場合は適当に修正してください。

id:iwana1999

空腹親父 様

早速、稼働しましたが想定通りに動きました。
お手数をお掛けしまして済みません。
有り難うございました。

なお、今後とも宜しくお願い致します。

2019/07/05 17:00:40

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません