Excel VBA 処理後データが重たくなる&処理スピードが遅いのを解決したい

以前にも質問しそこで回答を頂いた者です。

■VBAで実施したかったこと
一つのExcelファイルでマクロを実行すると、
その並列に並んでいるExcelファイルの中の欄外を一括削除するツール。
※細かい条件は添付ファイルをご参照

■課題
以下、VBAに詳しい教えてgooの詳しい方に教えて頂いたのですが、
二つ問題が起こっていて困っております。

①処理スピードが遅い（１ファイルあたり約10秒。100ファイルあるので、少しでも早いとうれしい）
②処理後、ファイルの容量が重たくなる（1ファイルで、100KBが10MBに膨れ上がる）

■御教示頂きたい事
以下VBAをどのように修正すれば、上記二つの課題をクリアできるでしょうか。
処理スピードが遅いのは最悪なんとかなるのですが、ファイル容量が重たくなるのはできれば避けたいと思っています。宜しくお願いします。

■　ＶＢＡ
Sub Sample()
Dim 名 As String
ChDir ThisWorkbook.Path
名 = Dir(ThisWorkbook.Path & "\*.*")
Do While 名 <> ""
If LCase$(Right$(名, 5)) = ".xlsx" Then
If LCase$(名) <> LCase$(ThisWorkbook.Name) Then
Workbooks.Open Filename:=名
Range(Cells(1, 4), Cells(Rows.Count, Columns.Count)).Delete
Range(Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1), Cells(Rows.Count, Columns.Count)).Delete
ActiveWorkbook.Save
ActiveWindow.Close
End If
End If
名 = Dir()
Loop
End Sub

No.3 ベストアンサー 回答者： WindFaller 回答日時： 2016/10/13 21:22

こちらの事情で、返事を待つ前に、こちらが考えたものを先に公開しておきます。

※ご質問の画像のようなデータで、「CurrentRegion」 で範囲が取れるという前提にしました。A1セルに対して、CurrentRegion で取れない場合は、以下のマクロはお使いにならないでください。（添付画像)

右端に関しては、、キメウチで、4列目を含め削除するということにしました。

最初に配列のファイル名を入れるというのは、単に私の書き方です。
また、あえて、ブックと処理するフォルダーが同一でなくてもよいと思います。
処理をしたものだけが、上書きされます。
記録を残すようにしました。Debug.Print が不要でしたら、コメントアウトや削除してよいです。


このロジックは、Excelの最終セルをジャンプで探し、データ範囲と比較して、斜め上まで、「削除(Delete)」ではなく「消去(Clear）」を使っています。したがって、OLEオブジェクトがあれば、削除できません。

'//
Sub CleaningExcelSheets()
　Dim Fname, MyPath
　Dim myArray
　Dim i As Long
　Dim LastCell As Range
　''拡張子が違っても、同名ファイルがないこと
　ReDim myArray(2000)
　MyPath = ThisWorkbook.Path & "\" '末尾には￥が必要
　Fname = Dir(MyPath & "*.xlsx", vbNormal)
　Do While Fname <> ""
　　If (GetAttr(MyPath & Fname) And vbNormal) = vbNormal Then
　　　i = i + 1
　　　myArray(i) = Fname
　　　If i > 2000 Then Exit Sub
　　End If
　　Fname = Dir
　Loop
　'以下ブックの処理
　ReDim Preserve myArray(i)
　Dim rw As Long, cl As Long
　Dim LRw As Long, LCl As Long
　Dim cRng As Range
　Application.ScreenUpdating = False
　For i = 1 To UBound(myArray)
　　With Workbooks.Open(MyPath & myArray(i))
　　　With .ActiveSheet
　　　　If Application.CountA(.Cells) > 0 Then
　　　　　
　　　　　'CurrentRegionで範囲を取る
　　　　　Set cRng = .Range("A1").CurrentRegion
　　　　　
　　　　　'最下行の次
　　　　　rw = cRng(cRng.Count).Row + 1
　　　　　'最右列の次 ->D列以降
　　　　　''cl = cRng(cRng.Count).Column + 1
　　　　　 cl = 4
　　　　　　
　　　　　'最後のセル
　　　　　Set LastCell = .Cells.SpecialCells(xlCellTypeLastCell)
　　　　　LRw = LastCell.Row
　　　　　LCl = LastCell.Column
　　　　　　　　　　
　　　　　If LRw >= rw Then
　　　　　　.Range(.Cells(rw, 1), LastCell).Clear
　　　　　End If
　　　　　
　　　　　If LCl >= cl Then
　　　　　　.Range(.Cells(1, cl), LastCell).Clear
　　　　　End If
　　　
　　　　End If
　　　End With
　　　If .Saved = False Then
　　　　.Save
　　　　 Debug.Print "s" & ActiveWorkbook.Name
　　　Else
　　　　 Debug.Print "n" & ActiveWorkbook.Name
　　　End If
　　　.Close False
　　End With
　Next
　Application.ScreenUpdating = True
　MsgBox "Finish!"
End Sub
'//
もしも、実行する場合は、メイン（消去)になるところは、なるべく理解した上で、行ってください。添付画像は、Range("A1").CurrentRegion.Select

この回答へのお礼

ご丁寧にありがとうございました。無事に実行できました。

お礼日時：2016/10/18 22:48

No.4 回答者： googoo900 回答日時： 2016/10/18 01:59

元データがどの程度の大きさなのかわかりませんが、残す範囲＜＜削除する範囲　になっており、メモリを多く使うため遅くなると推測して、狭いと思われる『残す範囲』を別シートにコピーするやり方にしました。

１つのファイルに1枚のシートという前提です。
100×50程度の適当に作ったファイル10個で試したところ、4秒程度で完了。１ファイル0.4秒というところでした。これは環境やサンプルファイルが異なるのであくまで参考ですが、写真に写っているファイルサイズの9kBは、自分がサンプルに使った処理後のファイルサイズと同じでした。
1ファイル10秒かかるとありますが、処理の後半で遅くなるのでしょうか？（メモリを消費してきてスワップが起こっている？）

Sub Sample00()
Dim 名 As String
Dim t0 As Time
Dim oldsheetname As String
Dim newsheetname As String
t0 = Time
ChDir ThisWorkbook.Path
名 = Dir(ThisWorkbook.Path & "\*.*")
Application.DisplayAlerts = False
Do While 名 <> ""
If LCase$(Right$(名, 5)) = ".xlsx" Then
If LCase$(名) <> LCase$(ThisWorkbook.Name) Then
Workbooks.Open Filename:=名
oldsheetname = ActiveSheet.Name
Sheets.Add
newsheetname = ActiveSheet.Name
Sheets(oldsheetname).Activate
Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 3)).Copy Worksheets(newsheetname).Range("a1")
Sheets(oldsheetname).Delete
ActiveWindow.Close SaveChanges:=True
End If
End If
名 = Dir()
Loop
Application.DisplayAlerts = True
MsgBox ("開始" & t0 & Chr(13) & "終了" & Time)
End Sub

この回答へのお礼

ご丁寧にありがとうございました。

お礼日時：2016/10/18 22:49

No.2 回答者： WindFaller 回答日時： 2016/10/13 00:17

こんばんは。

この話は、まず、初歩的な問題ですが、Excel等のVBEのオプションの設定から確認しなければならないと思います。

VBE-ツール-オプションの全般[TAB]の順次コンパイルは、オンで、バックグラウンドは、オフです。（私の場合)
エラートラップは、クラスモジュールで中断
ということにしてください。

それと、そのコードの作者に悪いけれども、私のPCのExcelなら、確実に死んでいます。

ちょっと条件をまとめました。

--------------------------
『並列に並んでいるExcelファイルの中の欄外を一括削除するツールを作りたい』

・行はA列の最下行を、列はCが最右列。それ以外は、欄外という定義。(※)
・「test用実行マクロ」を回すことにより、以下ファイルの仲の欄外データを一括で削除したい（ファイル名は規則性はない為、どんな名前のものでもExcelファイルであれば読み取るようにしたい)
・ひとつのファイルの中にはシートは1つしか存在していない
・列：D列以降の列は全て削除　◎（こちらはOKです)
--------------------------------
質問のコード自体は初歩的なコードでできるはずです。
しかし、条件的に足りない部分があって、マクロで行うにはとても手間が掛かる可能性が高いのです。

※・明確に欄の内側のデータと欄外とを分ける根拠がありません。
欄外を決めるものは、画像でみると、枠線の囲みということのようです。

A列の最下行という位置づけと、残しておきたいデータの最下行とに、必ず違いがあるとは確約するものはありません。罫線内にブランクがあった場合も、残すセルになるわけで、セルを一つずつ当たらなくてはなりません。

罫線を探すコードは非効率的だからです。
（SpecialCellsメソッドでできるように思われる人もいるかもしれませんが、それは意味が違って、罫線も含まれるということです)

Range("A1").CurrentRegionが使えるか、どうかぐらい。
確実に、CurrentRegion で範囲が取れるかどうかの確約を取りたいところです。Endプロパティでは失敗しかねません。

試しに、自分で作ったマクロでいくつかのサンプルを試してみましたが、やはりできたものと、できなかったものがありました。
もちろん、スピードの問題は、最初から解決しています。
----------------------------

なお、Excelのデータの最下行の1048576行は論理行で、物理的な最下行ではありません。そこを分かっていないと、この解答はできないと思います。VBAに命令すると、真っ正直に、マクロは、1048576行まで向かっていくのです。

この回答へのお礼

ありがとうございました。できました。

お礼日時：2016/10/18 22:48

No.1 回答者： くんこば 回答日時： 2016/10/10 22:26

難しそうです。

時間がかかっているであろう箇所が、「Rows.Count, Columns.Count」のとこ。
Excel2007から行数、列数が増えましたから、それを「現実的にデータがありそうな数」に変えてみては？

それでもかかるようなら、「ファイル開く、保存」に時間がかかるので、これはどうしようもないかな。

この回答へのお礼

ありがとうございました。

お礼日時：2016/10/18 22:49