空白セルがある行の左寄せ操作の件

質問

下記のようにＩ列に空白セルを検出し、その空白セルがある行においてＩ列からＭ列までのデータを左寄せする処理行っております。

For 番号 = 1 To Range("B1").End(xlDown).Row
　If Cells(番号, 9).Value = "" Then
　　 コピー開始列 = Cells(番号, 9).End(xlToRight).Column
　　 Range(Cells(番号, コピー開始列), Cells(番号,13)).Select
　　 Selection.Cut Destination:=Range(Cells(番号, 9),Cells(番号, 9 + 14 - コピー開始列))
　　 Range(Cells(番号, コピー開始列), Cells(番号,13)).Select
　End If
Next 番号

対象行数が３０００行ほどあり処理時間がかかりすぎるため、もう少し効率よいやり方があれば教えてください。

回答No.7

Randomize · ベストアンサー

No.6です。
MaxReadRow = Me.Cells(Me.Rows.Count, 2).End(xlUp).Row
の部分ですが、最悪
MaxReadRow = Me.Cells(65536, 2).End(xlUp).Row
でも動きます。
ただ、「Meの使い方が違う」といわれるところが気になります。標準モジュール内にプログラムを書き込んでいるのでしょうか？
もし標準モジュール内に記述しているのであればMeキーワードは使用できません。
MeをSheet1等のシートのコードネームに変更するか、
下のプログラムのように変更を加えるかしてください。
----------------------ここから-----------------------
Dim varRangeData() As Variant
Dim NowReadRow As Long, MaxReadRow As Long
Dim NowReadColumn As Integer, StartColumnNum As Integer
Const StartRow As Long = 1
Const ColumnOffset As Integer = 9
Const ColumnNumCount As Integer = 5
With ThisWorkbook.Sheets("Sheet1")
'↑の"Sheet1"部分を該当シート名に変更してください。
'With Sheet1 とシートのコードネームでも可能です
MaxReadRow = .Cells(.Rows.Count, 2).End(xlUp).Row
'I～M列のセルデータを全てメモリーへコピーする
varRangeData = .Range(.Cells(StartRow, ColumnOffset), .Cells(MaxReadRow, ColumnOffset + ColumnNumCount - 1)).Value
'↑セルのValueプロパティーだけのvarRangedata(1～行数,1～5)ができる
'I=>1 J=>2 K=>3 L=>4 M=>5 と読み替えてください
For NowReadRow = StartRow To MaxReadRow
If varRangeData(NowReadRow, 1) = "" Then
StartColumnNum = 0
'I列は空白と分かっているのでJ列からスキャン
For NowReadColumn = 2 To ColumnNumCount
If varRangeData(NowReadRow, NowReadColumn) <> "" Then
StartColumnNum = NowReadColumn
Exit For
End If
Next
If StartColumnNum <> 0 Then
'全てが空白の場合はStartColumnNumは0になりここには来ない
For NowReadColumn = 1 To ColumnNumCount
If NowReadColumn + StartColumnNum - 1 > ColumnNumCount Then
'元のデータがMより後の場所になる場合
varRangeData(NowReadRow, NowReadColumn) = ""
Else
'元のデータがM以前になる場合
varRangeData(NowReadRow, NowReadColumn) = varRangeData(NowReadRow, NowReadColumn + StartColumnNum - 1)
End If
Next
End If
End If
Next
'書き込む時には余分な処理が発生しないようにイベント・再計算・画面更新を停止する
'ただ、この例だと停止しなくても十分高速かもしれません
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
.Range(.Cells(StartRow, ColumnOffset), .Cells(MaxReadRow, ColumnOffset + ColumnNumCount - 1)).Value = varRangeData
'停止していた処理を再開するように設定する
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End With
----------------------ここまで-----------------------

お礼

Randomizeさん

　驚きました。
　1/90の時間に短縮できました。
　感謝感謝です。

回答No.11

Wendy02

こんにちは。

違反事項かもしれませんが、#2の　Sub test01()　のコードで間違いがないと思います。＞merlionX さん
わざわざ、そのスタイルを変える必要性はないと思いますね。

merlionXXさんの前回のコードを応用させていただいて、B列で判定するのもやめて、以下のようにしてみました。

データの範囲が全て左に移動しますから、もし、違うなら、この方法はだめだと思います。

Calculation のオンオフは、必要に応じて入れればよいです。
私のコードは、「標準モジュール」に置きます。
'---------------------------------------------------

Sub TestMacro1()
　　Dim i As Long
　　Dim j As Long
　　Dim rng As Range
　　Application.ScreenUpdating = False
　　With Range("I1").CurrentRegion
　　　　i = .Cells(.Cells.Count).Row
　　　　j = .Cells(.Cells.Count).Column - .Cells(1).Column + 1
　　　　Range("I1").Resize(i, j).SpecialCells(xlCellTypeBlanks).Delete (xlShiftToLeft)
　　End With
　　Application.ScreenUpdating = True
　　Set rng = Nothing
End Sub

'--------------------------------------------------
'右側にデータがある場合
'j = .Cells(.Cells.Count).Column - .Cells(1).Column + 1　の部分を調整します。

Sub TestMacro2()
　　Dim rng As Range
　　Dim i As Long
　　Dim j As Long
　　Application.ScreenUpdating = False
　　With Range("I1").CurrentRegion
　　　　i = .Cells(.Cells.Count).Row
　　　　j = .Cells(.Cells.Count).Column - .Cells(1).Column + 1
　　　　Set rng = Range("I1").Resize(i, j)
　　End With
　　With Worksheets.Add
　　　　rng.Copy .Range("A1")
　　　　.Range("A1").Resize(i, j).SpecialCells(xlCellTypeBlanks).Delete (xlShiftToLeft)
　　　　.Range("A1").Resize(i, j).Copy rng
　　　　Application.DisplayAlerts = False
　　　　.Delete
　　　　Application.DisplayAlerts = True
　　End With
　　Application.ScreenUpdating = True
　　Set rng = Nothing
End Sub
'--------------------------------------------------

この処理範囲は、あくまでも、I列からなんらかのデータが続いていることが条件です。間が開いていれば、その先は、処理されません。その場合は、i は、変える必要があります。

　　i = Range("B65536").End(xlUp).Row

なお、別件ですが、ExcelのVBAは、もともと、ローカルモジュールがたくさんあるので、ローカルモジュールではなく、標準モジュールに書くのが基本です。しかし、コントロールツールのコマンドボタンなどに設定する場合は、Me キーワードが生きるのですが、シートをまたがないなら、シートを示すオブジェクトは通常は不要です。

お礼

merlionX さんが３回目に提示いただいた方法が望みの動きです。
Ｉ列～Ｌ列の範囲内で移動する方法をご提示いただきました。
ありがとうございました。

回答No.10

merlionXX

No2-5-8 merlionXXです。
テストしてみたらぜんぜんダメでした。
訂正します。

Sub TEST04()
Dim n As Long, i As Long
Dim c As Range
Dim myRw()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
n = 0
For Each c In Range("I1:I" & Range("B1").End(xlDown).Row).SpecialCells(xlCellTypeBlanks)
ReDim Preserve myRw(n)
myRw(n) = c.Row
n = n + 1
Next c
For i = 0 To UBound(myRw)
Set myC = Cells(myRw(i), "I")
Range(Cells(myRw(i), myC.End(xlToRight).Column), Cells(myRw(i), "M")).Cut Cells(myRw(i), "I")
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

お礼

merlionXXさん

　訂正ありがとうございます。
　何行か処理できない行がありましたが、数回繰り返すと今までの
　時間よりも短くできたので訂正前のでも使おうと思っていました。

　訂正いただいたので完全に動作することを確認いたしました。
　重ね重ねありがとうございました。
　感謝感謝です！

回答No.9

onlyrom

こういった類の質問の場合は、データの取りうる状態などが非常に重要になります。
小出しにしなで全てを提示しましょう。
そうでないと、回答者があたふたしてしまいますよ。(^^;;;

で、以下のような場合はないのですか。

　■：データあり、
　△：ブランク

＿＿＿Ｉ＿＿＿Ｊ＿＿Ｋ＿＿_Ｌ＿＿Ｍ＿＿Ｎ＿＿
１＿＿■＿＿■＿＿■＿＿△＿＿■＿＿■＿＿
２＿＿△＿＿■＿＿△＿＿■＿＿△＿＿■＿＿
３＿＿△＿＿△＿＿■＿＿△＿＿■＿＿■＿＿
４＿＿△＿＿△＿＿△＿＿■＿＿■＿＿■＿＿
５＿＿△＿＿△＿＿△＿＿■＿＿△＿＿■＿＿

なければ無視願います。

お礼

onlyromさん

　ご指摘の状態はありません。
　今後もう少し全体像が分かるような質問になるようにいたします。

回答No.8

merlionXX

No2-5　merlionXXです。
> Ｍ列以降にデータがある場合があります。
M列までは左に詰めていいんですね？
ならば

Sub TEST03()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
x = Range("B1").End(xlDown).Row
Set myRng = Range("I1:I" & x).SpecialCells(xlCellTypeBlanks)
For Each C In myRng
コピー開始列 = C.End(xlToRight).Column
Range(Cells(C.Row, コピー開始列), Cells(C.Row, "M")).Cut Cells(C.Row, "I")
Next C
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

M列は左に移動させたくないのなら
Range(Cells(C.Row, コピー開始列), Cells(C.Row, "M")).Cut を
Range(Cells(C.Row, コピー開始列), Cells(C.Row, "L")).Cut に変えてください。

お礼

merlionXXさん

　できました。
　速度も1/4になりました。
　今回不愉快な思いさせてしまい申し訳ありませんでした。
　気をつけます。
　ありがとうございました。

回答No.6

Randomize

セルの入力されている値しか扱えませんが(色つけ・数式・書式などは一切コピー不可)相当高速に動くマクロです。
----------------------ここから-----------------------
Dim varRangeData() As Variant
Dim NowReadRow As Long, MaxReadRow As Long
Dim NowReadColumn As Integer, StartColumnNum As Integer
Const StartRow As Long = 1
Const ColumnOffset As Integer = 9
Const ColumnNumCount As Integer = 5
MaxReadRow = Me.Cells(Me.Rows.Count, 2).End(xlUp).Row
'I～M列のセルデータを全てメモリーへコピーする
varRangeData = Me.Range(Me.Cells(StartRow, ColumnOffset), Me.Cells(MaxReadRow, ColumnOffset + ColumnNumCount - 1)).Value
'↑セルのValueプロパティーだけのvarRangedata(1～行数,1～5)ができる
'I=>1 J=>2 K=>3 L=>4 M=>5 と読み替えてください
For NowReadRow = StartRow To MaxReadRow
If varRangeData(NowReadRow, 1) = "" Then
StartColumnNum = 0
'I列は空白と分かっているのでJ列からスキャン
For NowReadColumn = 2 To ColumnNumCount
If varRangeData(NowReadRow, NowReadColumn) <> "" Then
StartColumnNum = NowReadColumn
Exit For
End If
Next
If StartColumnNum <> 0 Then
'全てが空白の場合はStartColumnNumは0になりここには来ない
For NowReadColumn = 1 To ColumnNumCount
If NowReadColumn + StartColumnNum - 1 > ColumnNumCount Then
'元のデータがMより後の場所になる場合
varRangeData(NowReadRow, NowReadColumn) = ""
Else
'元のデータがM以前になる場合
varRangeData(NowReadRow, NowReadColumn) = varRangeData(NowReadRow, NowReadColumn + StartColumnNum - 1)
End If
Next
End If
End If
Next
'書き込む時には余分な処理が発生しないようにイベント・再計算・画面更新を停止する
'ただ、この例だと停止しなくても十分高速かもしれません
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Me.Range(Me.Cells(StartRow, ColumnOffset), Me.Cells(MaxReadRow, ColumnOffset + ColumnNumCount - 1)).Value = varRangeData
'停止していた処理を再開するように設定する
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
----------------------ここまで-----------------------
このマクロは、セルのデータの入力されている値のみをすべてメモリーへコピーしてメモリー内のみで処理をしています。Excelのセルを直接操作すると、操作するたびに値が不正でないかなどのチェック動作が入るので処理が重たくなります。そのため、メモリー内のみで処理を行うと非常に高速になります。詳しくは参考URLを見てみてください。
マクロのプログラムを拝見させていただきましてぱっと思った高速化のためのポイントを以下に記します。
1. Selectionを使うのはやめましょう
2. 反復処理数の多い場面のFor Nextで指定するToの値は極力変数に格納しましょう。式で記述すると、ループするたびに余分な計算が入ります。
3. セルに書き込みを行う場合は、再描画・再計算をとめましょう(Changeイベントにマクロを記述している場合はイベントもとめましょう)
これも、参考URLのシリーズに載っていることですので、合わせて一読してみてください。
補足:
このソースは簡易的なテストしか行っておりません。バグが合った場合は申し訳ありません。

参考URL：

http://officetanaka.net/excel/vba/speed/s11.htm

お礼

Randomizeさん
　ご回答ありがとうございます。
　MaxReadRow = Me.Cells(Me.Rows.Count, 2).End(xlUp).Row　
　の行のMe.RowsのところのMeでコンパイルエラーとなります。
　「Meキーワードの使用方法が不正です」とコメントがあります。
　相当高速に動くということでぜひ動かさせていただきたいのですが。

回答No.5

merlionXX

No2です。
> 説明が足りなく”セル内の左寄せ”と誤解を招きました。
あなたの掲示したコードをみれば「セル内の左寄せ」ではないことぐらいわかりますよ。
だからそのように回答してありますが試してみたのですか？

お礼

merlionXXさん
　たいへん申し訳ありませんでした。
確認せずに回答してしまいました。本当にすみません。
処理速度は劇的に変わりました。
　Ｍ列以降にデータがある場合があります。Ｉ列からＬ列の間だけで左に寄せるためには先ほどご提示いただいたコードの中に範囲指定を追加すればできるのでしょうか。

回答No.4

imogasi

#1です。
そうでしたか。
ほかに思うことは、セル（範囲）の削除（これは時間がかかる元凶と思う。他に挿入などシートセル・行・列の構成を変えられるとエクセルは処理がしんどい）じゃなくて、
別シート（完成データシート用）に対応各行に値代入をして、実現してはどうですか。書式などを無視してしまうが困るかな。
Sheet1の最終行まで繰り返し。
作業はEnd(xkToRight）で始まりのれるを見つける。
そこから決まった列（または、End(xkToLeft）で見つけた列までの列をSheet２の同行のA列から各セルに代入していく。
コピー貼り付け方式も有るが（コピーという仕組みの処理のに時間がかからないか心配なので）、私はまず、代入法（Sheet2!Cells(i,K))=Sheet1!.cells(i,j)をやってみてほしい。普通は、メモリ間のデータ移動の時間でやれないかと思う）
＝＝＝＝
もうひとつ、コードの最初（ループ外）のほうに
ScreeenUpdating＝Falseを入れるのを忘れないことだ。

回答No.3

noname#99913

コードの最初と最後に、次の行を入れてみてください。

最初
Application.Calculation = xlManual
最後
Application.Calculation = xlAutomatic

回答No.2

merlionXX

もし、I列に空白がある行以外の行には途中の空白がないのであれば

Sub test01()
Dim x As Long
x = Range("B1").End(xlDown).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo line
Range("I1:M" & x).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
On Error GoTo 0
line:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

列に空白がある行以外の行にも途中の空白があり、これを左詰してはいけないのであれば

Sub test02()
Dim x As Long
x = Range("B1").End(xlDown).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Do
On Error GoTo line
Range("I1:I" & x).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
On Error GoTo 0
Loop
line:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

お礼

説明が足りなく”セル内の左寄せ”と誤解を招きました。
たいへん申し訳ありません。
処理したいことを表にすると下記になります。

　　　　　 I　 　　　J　 　　　K　 　　　L
1　　　データ１　　データ２　データ３　データ４
2　　　　　　　　　　データ４　データ５　データ６
3　　　　　　　　　　　　　　　　データ７　データ８
4　　　　　　　　　　　　　　　　　　　　　　データ９
　　　　　　　　　↓

　　　　　I　　　　J　　　　 K　　　　L
1　　　データ１　データ２　データ３　データ４＜－－何もしない
2　　　データ４　データ５　データ６　　　　　＜－－１セル分左へ
3　　　データ７　データ８　　　　　　　　　　＜－－２セル分左へ
4　　　データ９　　　　　　　　　　　　　　　＜－－３セル分左へ

可能であれば再度ご検討をお願いできますでしょうか。

回答No.1

imogasi

早くなるかどうか、普通の我々には計算・算出理論も知らず、わからないものだ。
他の方式によるコードをやってみるよりほか無い。
エクセルで３０００行ぐらいで時間がかかるというのは、普通ではないように思うが。
コード上ですっきりした処理方式・書き方は
（編集ージャンプーセル選択ー空白セルを使って）
Sub Test01()
d = 3000 'd= Range("I65536").End(xlUp).Row
Range("I2:I" & d).SpecialCells(xlCellTypeBlanks).Select
For Each cl In Selection
Range(cl.Offset(0, 0), cl.Offset(0, 5)).HorizontalAlignment = xlLeft
Next
End Sub
dは最下行で一般には
d= Range("I65536").End(xlUp).Row
これでやってみて早くなるかどうかな。やってみて。
空白セルが少ないのなら検索Find、FindNextで探してやるコードに刷るとか。
WEBに（Googleで）「VBA　Find」で照会すればたくさん出るので略。

お礼

説明が足りなく”セル内の左寄せ”と誤解を招きました。
たいへん申し訳ありません。
処理したいことを表にすると下記になります。

　　　　　 I　 　　　J　 　　　K　 　　　L
1　　　データ１　　データ２　データ３　データ４
2　　　　　　　　　　データ４　データ５　データ６
3　　　　　　　　　　　　　　　　データ７　データ８
4　　　　　　　　　　　　　　　　　　　　　　データ９
　　　　　　　　　↓

　　　　　I　　　　J　　　　 K　　　　L
1　　　データ１　データ２　データ３　データ４＜－－何もしない
2　　　データ４　データ５　データ６　　　　　＜－－１セル分左へ
3　　　データ７　データ８　　　　　　　　　　＜－－２セル分左へ
4　　　データ９　　　　　　　　　　　　　　　＜－－３セル分左へ

可能であれば再度ご検討をお願いできますでしょうか。