EXCELでセルの移動マクロを作りたいのですが…

EXCELについての質問です。マクロを使ってセルの移動をさせたいと考えています。

まず使うデータ範囲はA1:E11です。A1:E10にはデータが入っています。
ちなみに、A列には名前、B～E列には数字が入っており、A11:E11は合計が表示される設定しており、合計の場所はここに固定させたいのです。

その移動のさせ方ですが、
A1：E1に空欄があるとします。
そのときに、マクロを再生させるとA2:E10のセルに入っているデータ（値のみ）を上に移動させたいのです。
さらに、A3:E3の内容を消して空欄が出来たとします。
その時に同じ操作によってA4:E10のデータを上に移動させたいのです。

前者のマクロを単純に作ると縦に9つ分のセルを移動させるマクロでは、
A11:E11も上に移動させられてしまいます。なので、移動させるセルの一番下が10行目になるようなマクロを作りたいのです。

何がしたいのかといいますと、いらないデータを消した時に空欄をマクロで詰めてしまいたいのです。

乱文で判りづらいかと思いますが、知識のある方教えていただけないでしょうか。
よろしくお願い致します。

No.1 回答者： zap35 回答日時： 2007/11/02 16:44

そのようなマクロを作ってみました。

以下のマクロをALT＋F11でVBE画面を開き、左上のVBA Projectでシート名を右クリックし「挿入」→「標準モジュール」で表示される画面に貼り付けて下さい。マクロの実行はワークシート画面に戻ってALT＋F8でマクロ一覧を開き、マクロ名を選択して「実行」ボタンです。

でもA1:E10が「例えば」の例でなければ良いのですが。もし違うならそれなりに手を入れないとダメですよ。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim idx As Integer
Dim rng As Range
　　Set rng = Intersect(Target, Rows("1:10"))
　　If Not rng Is Nothing Then
　　　　On Error GoTo err0
　　　　Application.EnableEvents = False
　　　　For idx = 10 To 1 Step -1
　　　　　　If Application.CountA(Cells(idx, "A").Resize(1, 5)) = 0 Then
　　　　　　　　Cells(idx + 1, "A").Resize(11 - idx, 5).Copy Cells(idx, "A")
　　　　　　　　Cells(10, "A").Resize(1, 5).ClearContents
　　　　　　End If
　　　　Next idx
　　End If
err0:
　　Application.EnableEvents = True
End Sub

この回答への補足

あと、もう一つお尋ねしたいのがコピーした際に、罫線も一緒に移動するのですが、罫線等の書式はそのままで値のみ移動させることは可能なのでしょうか?たとえ無理だとしてもこんなことが出来るなんて…zap35さんをリスペクトです☆

補足日時：2007/11/05 09:51

この回答へのお礼

早速の回答ありがとうございます！！
実際に行の値を消した時に下の値が動いたときはびっくりして思わず声が出てしまいましたｗ

今回、合計行がA1:E10にしておりますが、もし、合計行がもっと下に来た場合はどの値を変えればよいのでしょうか？いろんなサイズで使えたらと思いますので是非教えていただきたいです。m(_ _)m

お礼日時：2007/11/05 09:46

No.2 回答者： zap35 回答日時： 2007/11/02 16:51

＃０１です

マクロを貼り付ける場所の説明を間違えました

入力するシートの「シート名タブ右クリック」→「コードの表示」で開く画面に貼り付けてください

ワークシート画面に戻って、適当な行のデータを削除してみてください
ただし本当の行削除を行うと合計行も上にずれてしまいますから、気をつけてくださいね

No.3 ベストアンサー 回答者： zap35 回答日時： 2007/11/05 16:00

＃０１です。

汎用的にしてみました。４～７行目を変更してください
また貼り付けも値のみにしています

Private Sub Worksheet_Change(ByVal Target As Range)
Dim idx, cnt As Integer
Dim rng As Range
Const fRow As Integer = 1　 'データ開始行
Const tRow As Integer = 10　'データ最終行
Const fCol As String = "A"　'データ開始列
Const tCol As String = "E"　'データ最終列
　　Set rng = Intersect(Target, Rows(fRow & ":" & tRow))
　　If Not rng Is Nothing Then
　　　　cnt = Columns(fCol & ":" & tCol).Count
　　　　On Error GoTo err0
　　　　Application.ScreenUpdating = False
　　　　Application.EnableEvents = False
　　　　For idx = tRow - 1 To fRow Step -1
　　　　　　If Application.CountA(Cells(idx, fCol).Resize(1, cnt)) = 0 Then
　　　　　　　　Cells(idx + 1, fCol).Resize(tRow - idx, cnt).Copy
　　　　　　　　Cells(idx, fCol).PasteSpecial Paste:=xlPasteValues
　　　　　　　　Cells(tRow, fCol).Resize(1, cnt).ClearContents
　　　　　　End If
　　　　Next idx
　　　　Target.Select
　　End If
err0:
　　Application.CutCopyMode = False
　　Application.EnableEvents = True
　　Application.ScreenUpdating = True
End Sub

この回答へのお礼

判りやすいプログラムありがとうございます。
個人的には500ptつけたいぐらい親切に対応してくださって感謝です。。
本当は同じような感じで他の列も同じシートでやりたいんですが…そこまでは贅沢ですよね（汗

本当に助かりました。ありがとうございます★★★

お礼日時：2007/11/06 09:52