ExcelVBA 表に空白があれば行単位で詰めたい

質問

初心者です。
ExcelVBA2007で、A3:G15の表があります。（さらに実際は横にも同じようにI3:O3にもさらに下にも同じような表がいくつかあります）
この表は、行ごとに1セットになっています。（例えばA3に分類、B3に商品名・・・G3に数のように）
この表の所々に空欄があるのですが、一つの表の中の行がすべて空欄であれば上に詰めていきたいと思っていますがうまくいきません。後、D列には数式が入っているのですが処理がかわってくるのでしょうか？（今後数式を入れない方向に変えようかとも思っています）
どうすればよいでしょうか？
もしよかったら、同じ表に対する繰り返し処理のスマートな表記があれば教えていただければありがたいです。
申し訳ございませんが、ご教授よろしくお願いいたします。

回答No.3

zongai · ベストアンサー

IF の条件が同一で複数の処理を行う場合、1つのIFでまとめられます。
というのは多分ご存じですよね。

全体の処理を7回繰り返しているとのことですが、空白行が多いと処理漏れが出てくるのでは…？
「On Error」は「.SpecialCells(xlCellTypeConstants)」のためのものですよね？

すみません、以下、勝手にいじったものをあげておきます。
時間の都合と、私の能力の関係で、汚く見づらいと思いますので覚悟して眺めてください。
認識が違っているかもしれませんが、どこかしら役に立つ部分があれば、と期待しつつ。

Sub aaa()
　　Dim i As Integer, x As Integer, y As Integer
　　Application.ScreenUpdating = False
　　Flag = 0　'★1回だけの処理で使うフラグ
'　　For i = 1 To 7　　★1回で済ませたいのでコメント化
　　　　For x = 14 To 3 Step -1 '15行→3行まで処理をします。
　　　　　　CSUM = 0 '列の文字数を数える変数CSUMを用意し、初期値0とします。
　　　　　　For y = 1 To 7 'A列（1列）→G列（7列）まで処理をします。
　　　　　　　　CSUM = CSUM + Len(Cells(x, y)) 'CSUMにセル（x,y）の文字数を足します。
　　　　　　Next '列処理繰り返し
'　　　　　　On Error Resume Next　　★「On Error」嫌いなのでコメント化
　　　　　　If CSUM = 0 Then
　　　　　　　　Range(Cells(x + 1, 1), Cells(15, 7)).Copy　　'★空白行の1行下から15行目までをコピー
　　　　　　　　Cells(x, 1).PasteSpecial　　'★空白行の1列目のセルを基点として貼り付け
　　　　　　　　If Flag = 0 Then　　'★15行目の値クリア処理　1回だけの処理
　　　　　　　　　　Cells(15, 1) = 1　　'★15行目がすっからかんのときエラーになるので、暫定入力
　　　　　　　　　　Range(Cells(15, 1), Cells(15, 7)).SpecialCells(xlCellTypeConstants).ClearContents
　　　　　　　　End If　　'★1回だけの処理　ここまで
　　　　　　　　Flag = 1　　'★1回だけの処理させないためフラグ値変更
　　　　　　End If
　　　　　　Application.CutCopyMode = False
'　　　　　　On Error GoTo 0　　★「On Error」嫌いなのでコメント化
　　　　Next '行処理繰り返し
'　　Nex　★1回で済ませたいのでコメント化
End Sub

★のコメントが、今回いじったあたりもの

空白行発見時、
その下の行から15行目までをコピー　→　空白行から貼り付け
としています。
これで、7回ループしなくて良くなると思います。

15行目のクリアは1回実行すれば不要となるので、変数「Flag」を用意しました。
Flag = 0　のときに1度実行。その後、Flag = 1　とすることで、以降処理を省きます。

15行目が全くカラの状態だと「.SpecialCells(xlCellTypeConstants)」でエラーとなるので、暫定的に「1」を入力しています。
これで、私があんまり使いたくない「On Error」を使わずに済みます。

ほかの処理だと・・・
空白行を上に詰めて、最後に表範囲に罫線を引き直すという
という方法もありますよね。

お礼

さらに考えていただきどうもありがとうございます。
試してみました。
こっちの方が、処理が速くていいですね。
解説もつけていただきどうもありがとうございます。
感謝です。

回答No.2

zongai

ごめんなさい、対象のセル範囲を［C3:G15］としてました。
こちら、[A3:G15］としたものです。

Sub aaa()
　　For x = 15 To 3 Step -1　　'15行→3行まで処理をします。
　　　　CSUM = 0　　'列の文字数を数える変数CSUMを用意し、初期値0とします。
　　　　For y = 1 To 7　　'A列（1列）→G列（7列）まで処理をします。
　　　　　　　　CSUM = CSUM + Len(Cells(x, y))　　'CSUMにセル（x,y）の文字数を足します。
　　　　Next　　'列処理繰り返し
　　　　If CSUM = 0 Then Range(Cells(x, 1), Cells(x, 7)).Delete Shift:=xlUp　　'文字数が0なら、範囲x行のA～G列（1～7列）までを削除して上へ詰めます。
　　Next　　'行処理繰り返し
End Sub

＜流れを簡単に…＞
15行から3行に向かい、以下の処理をする。
その行のA列にあたるセルからG列にあたるセルまでの文字数を順に足していく。
その行の文字数が0だったら、その行のA列～G列を削除し、上へ詰める。

なお、D列に数式が入っているとのことですが、結果として空白（文字が無い）のであれば空欄として処理します。

さて、セル範囲を間違ったものをアップしてしまっていたわけですが・・・
・表の一部が削除されるので表がくずれてしまう
の部分については、修正がさほど難しい部類ではありません。
これに気付けないとなると、参考となるマクロを教えていただいても、ここから編集、改良は難しいのでは…と心配です。

・表の途中に何も入力しない行をつくって下の行にある文字が上の何も入力していない行に詰めてくれませんでした。
こちらについては原因がわかりませんが、今回もので、セル範囲［A3:G15]の中で試してみてください。

お役にたてれば幸いです。

補足

どうもありがとうございます。
一応、このコードを元につくってみて思い通りに動作するようになりました。
Delete の所を1行下をコピーして貼り付けるようにしました。
空白行の状態では、上に詰まりきらないので全体を繰り返しました。色々試した結果3～15行までの13行に対して半分程度の7回繰り返せば大丈夫でした。
後、気になるのがコードの書き方です。追加した部分がIf CSUM = 0を連続で書いています。elseとかで書こうとしたのですが、ForがないとかEnd　ifがないとかでエラーになってしまいしょうがなく、このような書き方になってしまいました。

一応思い通りの動作なので問題ないのですが、勉強のためにもっとスマートな書き方があればご教授ください。

Sub aaa()
Dim i As Integer, x As Integer, y As Integer

Application.ScreenUpdating = False
For i = 1 To 7

For x = 14 To 3 Step -1 '15行→3行まで処理をします。
CSUM = 0 '列の文字数を数える変数CSUMを用意し、初期値0とします。
For y = 1 To 7 'A列（1列）→G列（7列）まで処理をします。
CSUM = CSUM + Len(Cells(x, y)) 'CSUMにセル（x,y）の文字数を足します。
Next '列処理繰り返し
On Error Resume Next
If CSUM = 0 Then Range(Cells(x + 1, 1), Cells(x + 1, 7)).Copy
If CSUM = 0 Then Range(Cells(x, 1), Cells(x, 7)).PasteSpecial
If CSUM = 0 Then Range(Cells(x + 1, 1), Cells(x + 1, 7)).SpecialCells(xlCellTypeConstants).ClearContents
Application.CutCopyMode = False
On Error GoTo 0
Next '行処理繰り返し
Next

End Sub

回答No.1

zongai

どの部分で詰まっているのかよくわかりませんが・・・

Sub aaa()
For x = 15 To 3 Step -1
CSUM = 0
For y = 3 To 7
CSUM = CSUM + Len(Cells(x, y))
Next
If CSUM = 0 Then Range(Cells(x, 3), Cells(x, 7)).Delete Shift:=xlUp
Next
End Sub

とりあえず、これで足りないところをあげてみるとか。(^_^;

補足

すいません、変えながら色々やってみましたがやはりうまくいきません。表の一部が削除されるので表がくずれてしまうし、動作も表の途中に何も入力しない行をつくって下の行にある文字が上の何も入力していない行に詰めてくれませんでした。