|
いつもお世話になっております。解決策をご教授くださいませ。
シート16-30のデータをオートフィルターを使用してH行でソート、
ソートしたデータをシート1-15へデータを貼り付ける
(シート16はシート1、シート17はシート2へと順番に)
全部の記述を長いマクロで書いていた時は動いていたのですが、
繰り返しのマクロを使用して可読性を向上させようとしたところ
途中でメモリ不足になってしまうようになりました。
エラーで止まってしまうところまでは上手く動いているのですが・・・
手探りでネットを探して、見よう見まねで
DoEvents
Erase DynamicArray
の構文を入れてみましたが改善されず。お助けください・・・
Sub 貼り付け()
'
'
'
Application.ScreenUpdating = False
On Error Resume Next
Dim i As Integer
For i = 16 To 30
'
'
'3
Sheets(i).Select
Rows("41:41").Select
Selection.AutoFilter
Range("A41").CurrentRegion.AutoFilter Field:=8, Criteria1:="3"
Range("A41:F41").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets(i - 15).Select
Range("A35").PasteSpecial Paste:=xlPasteValues
'
'4
Sheets(i).Select
Rows("41:41").Select
Selection.AutoFilter
ActiveSheet.Range("$A$41:$H$5000").AutoFilter Field:=8, Criteria1:="4"
Range("A41:F41").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets(i - 15).Select
Range("Q35").PasteSpecial Paste:=xlPasteValues
'
'5
Sheets(i).Select
Rows("41:41").Select
Selection.AutoFilter
ActiveSheet.Range("$A$41:$H$5000").AutoFilter Field:=8, Criteria1:="5"
Range("A41:F41").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets(i - 15).Select
'
'6
Sheets(i).Select
Rows("41:41").Select
Selection.AutoFilter
ActiveSheet.Range("$A$41:$H$5000").AutoFilter Field:=8, Criteria1:="6"
Range("A41:F41").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets(i - 15).Select
'
'
'
'
Range("A32").Select
Sheets(i).Select
Rows("41:41").Select
Selection.AutoFilter
Range("A42").Select
DoEvents
Next
'
'
Erase DynamicArray
Sheets(16).Select
Application.ScreenUpdating = True
|
|