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

回答No.4

tom04 · ベストアンサー

何度もごめんなさい。
前回は大きな勘違いをしていました。

各票の1列目には数式が入っていて、その数式は消さずに2列目～8列目を消去　→　上詰め
というコトですね？

とりあえずSheet2を作業用のSheetとして使っていますので、
Sheet2は使っていない状態にしておいてください。
（実際は操作したいSheetの使っていないセルでも構いません）

Sub Sample2()
Dim i As Long, j As Long, k As Long, cnt As Long
Dim myRng As Range, wS As Worksheet, myAry

Set wS = Worksheets("Sheet2") '★
myAry = Array("D4", "D30", "N4", "N30") '←に各表の最初のセル番地を追加　★

Application.ScreenUpdating = False
For k = 0 To UBound(myAry)
Set myRng = Range(myAry(k)).Resize(20, 8)
wS.Range("A1").Formula = myRng(1).Formula '★（表の1行目・1列目の数式をSheet2のA1セルに一旦表示させる）
For i = 145 To 1 Step -8
For j = 1 To 7 '★ myRngの i 番目セルの右となりから表の右端のセルまで
If myRng(i).Offset(, j) = "" Then
cnt = cnt + 1
End If
Next j
If cnt = 7 Then '★（前回「8」の部分が「7」に変更）
myRng(i).Offset(, 1).Resize(, 7).Delete shift:=xlUp
myRng(153).Offset(, 1).Resize(, 7).Insert shift:=xlDown
myRng(i).Offset(, 1).Resize(, 7).Copy
myRng(153).Offset(, 1).PasteSpecial Paste:=xlPasteFormats
myRng(1).Resize(20).Formula = wS.Range("A1").Formula '★Sheet2・A1セルの数式を元の表に戻す
End If
cnt = 0
Next i
Next k
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

※　myAry　宣言の手抜きを指摘いただきどうもありがとうございます。
何も宣言しない場合は「Valiant」型になりますので、宣言していませんでした。
本来はご指摘のように丁寧に宣言する方が良いと思います。

※　今度はどうでしょうか？m(_ _)m

お礼

どうもありがとうございます。結論的にはうまく動きました。
これで完成か、と思い別シートを見たところ、#REF表示がいっぱい出ていました。
表の内容を参照していた所のセルが削除されたためでした。

今回のファイルには、行を削除してまた作るやり方は不適でした。
またの機会に使わせていただきます。

質問はまたその条件で再投稿いたします。この質問はこれで閉めます。
色々協力していただいたのですが、結果このようになってしまい申し訳ございませんでした。
再投稿しますので、良い案があればご教授くださればと思います。

本当にどうもありがとうございました。

回答No.5

tom04

何度も何度も失礼します。

前回の投稿で誤記がありました。
＞「Valiant」型
は
＞「Variant」型
の間違いです。

どうも失礼しました。m(_ _)m

お礼

どうも、わざわざありがとうございます。
この度は、お世話になりました。

回答No.3

tom04

続けてお邪魔します。

＞ただ、各表の一列目に数式が入っていたのが削除されていたのでそれを再書き込みする必要がありました。

各表の1行目に手を付けてはいけなかったのですね？
前回のコードの
＞For i = 145 To 1 Step -8
の行を
＞For i = 145 To 9 Step -8
に変更してみてください。
（前回アップした画像の145番目のセルから9番目のセルまで）

これで各表の1行目は何も変わらないはずです。m(_ _)m

補足

1行目ではなく、各表の1列目のみ全部関数が入っています。
例えば最初のセル番地であるD4セルには=IF(F4="","","AAA")
という関数が入っています。残りも同じ関数で相対参照になっています。

1列除いてやったら、参照先がなくなって#REFになってしまいました。

とりあえず、現在は最低でも最初のセル番地は関数が残っているので、myAryを使って格納してコピーして下の19行に貼り付ければいけそうですが、うまくいかずエラーになっています。
とりあえず Dim myAry As Variant　が抜けていました。

どう指定すれば効率よくできるでしょうか？

回答No.2

tom04

No.1です。

＞とりあえず一つの表のみで適当に入力してやってみましたが何も変化しません。

表の配置は前回アップした配置になっているでしょうか？
こちらでD4～K23セルを一つの表として前回のコードでやってみました。
データが1つも表示されていない行はちゃんと削除され上詰めできました。

考えられる原因としては、
1つの表が20行・8列となっているか？くらいです。

それと質問をよく読み返してみると
表は12か所あるというコトですね？

コード内の「myAry」の部分に
各表の最初のセル番地を追加してください。
各表とも同じ行数・列数であればいくつ追加しても構いません。

直接の解決とはいかないと思いますが、
ごめんなさいね。m(_ _)m

お礼

度々すいません。動いたという事でもう一度してもだめで、新規ブックに表をつくってしたらできたのでもう一度もどって、コードのコピーからやり直したらなぜか出来ました。

どうもありがとうございます。
ただ、各表の一列目に数式が入っていたのが削除されていたのでそれを再書き込みする必要がありました。

また、それで試してみます。
ありがとうございました。

回答No.1

tom04

こんばんは！

＞このような表が同じ列に4か所×3＝12か所あるので・・・
というコトですので、一案です。

考え方として↓の画像のように一つの表の範囲が160セルになると思いますので、
各表を「myRng」に格納します。
番号を振っているのが「myRng」の順番となります。
その最左列を基準としてやってみました。

Sub Sample1()
Dim i As Long, j As Long, k As Long, cnt As Long
Dim myRng As Range, myAry

'▼4つの表の最初のセル番地を　myAry　に格納
myAry = Array("D4", "D30", "N4", "N30")

Application.ScreenUpdating = False
'▼myAryの最初～最後まで
For k = 0 To UBound(myAry)
'▼ myAry　のセル番地から20行、8列を myRng に格納
Set myRng = Range(myAry(k)).Resize(20, 8)
'▼　myRng　の最後から2行目から　myRng　の1行目まで
For i = 145 To 1 Step -8
'▼列方向にループ
For j = 0 To 7
If myRng(i).Offset(, j) = "" Then
cnt = cnt + 1
End If
Next j
'▼ myRng　i 番目セルの行すべてが空白の場合、
'その行を削除し最終行を1行挿入、最終行の書式を整える
If cnt = 8 Then
myRng(i).Resize(, 8).Delete shift:=xlUp
myRng(153).Resize(, 8).Insert shift:=xlDown
myRng(i).Resize(, 8).Copy
myRng(153).PasteSpecial Paste:=xlPasteFormats
End If
cnt = 0
Next i
Next k
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

※　もっと良い方法があるかもしれませんが、
とりあえずはこの程度で・・・m(_ _)m

補足

こんばんは。早速どうもありがとうございます。
動きは早そうです。でも、とりあえず一つの表のみで適当に入力してやってみましたが何も変化しません。
空白行があればDeleteされるようになっていますが、見ていてもなぜか分かりませんが消されてないようです。

どこかおかしいのでしょうかね？