Excelvba表に空白行があれば上に詰める重い
いつもお世話になっております。
列がD列からK列で、行が4行目から23行までの表があります。
その表で1行まるまる空白の時（4行目にには数式が入っていますがそれは除く）
上の行に詰めるようにしてあります。行はそのまま空白のまま残して、値のみ上に詰めるようにしています。
このような表が同じ列に4か所×3＝12か所あるので、今はそれぞれ下のコードの行、列を変更して処理しています。
上の表と下のの表の間隔は、上が４～23行までで、下は30～49、と6行間隔です。結合セルも間にあるため5行空きがあります。
列と列の間隔は、左側から、D列～K列、続いて、N列～U列と続きます。2列空きがあります。
家で試した時は一応問題なく動いたのですが、
会社でした時フリーズしてしまい、うまくいきませんでした。
その後、家でしてもなぜかうまく動作しなくなりました。
１２の表は多いのかと思い、1つで試してもだめになりました。
同じような作りの別のファイルは動いています。
念のため、新しいファイルにコピーし直してやりましたが、駄目でした。
コードもあまり良くないのかもしれません。
一応家ではVISTAの2007で試し、会社は7(32ビット)の2013です。
もう少し負担が少なくなるようなやり方があればと思っています。
もう少し、いいやり方があればお手数ですが、ご教授ください。
よろしくお願いいたします。
Sub 表の空白行は上に詰める()
Dim i As Integer, x As Integer, y As Integer, CSUM As Integer
Dim flag As Boolean
Application.ScreenUpdating = False
flag = 0 '1回だけの処理で使うフラグ
For x = 22 To 4 Step -1 '23行→4行まで処理をします。
CSUM = 0 '列の文字数を数える変数CSUMを用意し、初期値0とします。
For y = 4 To 11 'D列→K列まで処理をします。
CSUM = CSUM + Len(Cells(x, y)) 'CSUMにセル（x,y）の文字数を足します。
Next '列処理繰り返し
If CSUM = 0 Then
Range(Cells(x + 1, 4), Cells(23, 11)).Copy '空白行の1行下から23行目までをコピー
Cells(x, 4).PasteSpecial '空白行の1列目のセルを基点として貼り付け
If flag = 0 Then '23行目の値クリア処理 1回だけの処理
Cells(23, 5) = 1 '23行目がすっからかんのときエラーになるので、暫定入力
Range(Cells(23, 4), Cells(23, 11)).SpecialCells(xlCellTypeConstants).ClearContents
End If '1回だけの処理 ここまで
flag = 1 '1回だけの処理させないためフラグ値変更
End If
Application.CutCopyMode = False
Next '行処理繰り返し
End Sub
お礼
簡単にはできないのですね。参考書一冊買わないといけませんか。 ありがとうございました。