Excelvba表に空白行の時上に詰める不安定関数

質問

いつもお世話になっております。
前回の質問で条件が抜けておりましたので、こちらに再投稿いたしました。すいませんでした。
http://okwave.jp/qa/q8881161.html

列がD列からK列で、行が4行目から23行までの表があります。

その表で1行まるまる空白の時（表の1列目（例えばD4セルには、 =IF(F4="","","AAA") には数式が入っていますがそれは除く） 上の行に詰めるようにしてあります。行はそのまま空白のまま残して、値のみ上に詰めるようにしています。（表の行数は変わらない事）

このような表が同じ列に4か所×3（他の列）＝12か所あります。
上の表と下の表の間隔は、上が４～23行までで、下は30～49、と6行間隔です。結合セルも間にあるため5行空きがあります。
列と列の間隔は、左側から、D列～K列、続いて、N列～U列と続きます。2列空きがあります。

家で試した時は一応問題なく動いたのですが、 違うＰＣだとフリーズしてしまい、うまくいきませんでした。その後、家でしてもなぜかうまく動作しなくなりました。
１２の表は多いのかと思い、1つで試してもだめになりました。

同じような作りの別のファイルは動いています。
念のため、新しいファイルにコピーし直してやりましたが、駄目でした。
コードもあまり良くないのかもしれません。

もう少し負担が少なくなるような効率のよいコードがあればと思っています。
条件として、別シートでこの表のセルを参照しているので、一旦行を削除して、新たに下に作るというやり方をすると、関数式のセルが#REFになってしますので不可です。

もう少し、いいやり方があればお手数ですが、ご教授ください。
よろしくお願いいたします。現在のコードです。このコードを12個行列を変えたものを使っています。
これはなぜか今はうまく動いていません。

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.1

tom04 · ベストアンサー

こんばんは！
前回回答した者です。

＞条件として、別シートでこの表のセルを参照しているので・・・
というコトは結局コピー＆ペーストしていくしかないのかもしれませんね。

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

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

Application.ScreenUpdating = False
For k = 0 To UBound(myAry)
Set myRng = Range(myAry(k)).Resize(20, 8)

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
myRng(i).Offset(1, 1).Resize((153 - i) / 8, 7).Copy myRng(i).Offset(, 1)
myRng(153).Offset(, 1).Resize(, 7).Copy
myRng(i).Offset(, 1).PasteSpecial Paste:=xlPasteFormats
If WorksheetFunction.CountA(myRng(153).Offset(, 1).Resize(, 7)) > 0 Then
myRng(153).Offset(, 1).Resize(, 7).ClearContents
End If
End If
cnt = 0
Next i
Next k
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

これを使うシートはコピーを極力せず新規に作ったらフリーズしなくなりました。
ほかのシートは前のをそのまま移動して使っていますが、問題はなくなりました。
きちんと動作します。
いろいろお手数をおかけし、すいませんでした。

今回は長々とどうもありがとうございました。

補足

早速の投稿ありがとうございます。
No.2の投稿の部分を含めて試してみました。
画面が白くなってフリーズしてしまいます。DoEventsを間に適当に入れてみたのですがだめでした。

最初のと同じ症状です。何度も試しているとファイル自体壊れるのか、表を4つほどコピーして新規ファイルに普通に貼り付けようとしただけでフリーズしてしまいコピーできなくなってしまいました。（コピーで試しているので問題ないですが）

色々試すとどうも、空白行が多いとフリーズするようです。空白行が少ないときはきれいに動きましたが、20行×8列の表で1行だけ入力とかで試すと1つの表だけでもフリーズしてしまいます。

何が問題なのでしょうかね？

回答No.3

tom04

たびたびごめんなさい。

＞画面が白くなってフリーズしてしまいます
というコトですので・・・
極力ループさせない方法にしてみました。

各表の2列目以降は実データ（数式などによって「空白」に見えているセルではない！）
という前提です。

Sub Sample4()
Dim i As Long, k As Long
Dim myRng As Range, myAry

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

Application.ScreenUpdating = False
For k = 0 To UBound(myAry)
Set myRng = Range(myAry(k)).Resize(20, 8)

For i = 145 To 1 Step -8
If WorksheetFunction.CountA(myRng(i).Offset(, 1).Resize(, 7)) = 0 Then
myRng(i).Offset(1, 1).Resize((153 - i) / 8, 7).Copy
myRng(i).Offset(, 1).PasteSpecial Paste:=xlPasteValues
If WorksheetFunction.CountA(myRng(153).Offset(, 1).Resize(, 7)) > 0 Then
myRng(153).Offset(, 1).Resize(, 7).ClearContents
End If
End If
Next i
Next k
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

※最低限のループでとどめ、コピー＆ペーストは「値」だけにしてみました。
今度はどうでしょうか？

※　余談ですが、当方でも表の範囲を10個程度に増やして
前回のコードでやってみましたが、そんなに時間を要することはありませんでした。

何か数式などで時間を要するような関数が使われているといったことはないでしょうか？

これでもダメならごめんなさいね。m(_ _)m

お礼

フリーズするので、新規のシートに表のみコピーして作って試したのですが、駄目だったのですが、改めてコピーせずに新規で作り変えてみました。
すると、軽く動作しました。
どうも、何か分かりませんがおかしくなっていたようです。
特にオブジェクトもなく、容量も大きくなかったのですが、とりあえず軽快に動作するようになりました。
どうもありがとうございます。
もう少し、すべて復元して正式に動作すればこれでいけそうです。

回答No.2

tom04

No.1です。
たびたびごめんなさい。

投稿後気づきました。前回のコードで不要な行があります。

＞myRng(153).Offset(, 1).Resize(, 7).Copy
＞myRng(i).Offset(, 1).PasteSpecial Paste:=xlPasteFormats

の2行を消してください。
全く無意味でした。m(_ _)m