Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
872 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【77825】メモリ不足の解消の仕方 YUKI 16/1/6(水) 15:43 質問[未読]
【77826】Re:メモリ不足の解消の仕方 β 16/1/6(水) 19:18 発言[未読]
【77827】Re:メモリ不足の解消の仕方 β 16/1/6(水) 19:36 発言[未読]
【77828】Re:メモリ不足の解消の仕方 β 16/1/6(水) 20:59 発言[未読]
【77829】Re:メモリ不足の解消の仕方 YUKI 16/1/7(木) 15:24 お礼[未読]
【77825】メモリ不足の解消の仕方
質問  YUKI  - 16/1/6(水) 15:43 -
引用なし
パスワード
   いつもお世話になっております。解決策をご教授くださいませ。

シート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
【77826】Re:メモリ不足の解消の仕方
発言  β  - 16/1/6(水) 19:18 -
引用なし
パスワード
   ▼YUKI さん：

コードはまだ読んでいないのですが、DynamicArray って何ですか？
どこにも登場しないんですが。

それと、コードの不具合を追いかける場合（だけではないですが）
きちんとインデントをつけてコードを記述する習慣をつけることを強く推奨します。

あと、使用している変数も、すべて宣言しましょう。
【77827】Re:メモリ不足の解消の仕方
発言  β  - 16/1/6(水) 19:36 -
引用なし
パスワード
   ▼YUKI さん：

コードの記述スタイルは、改善の余地が多々ありますが、いったん、それはさておき。

シートの41行目がタイトル行で、42行目からデータ。
H列で、フィルタリングして、それを別シートのしかるべき場所に転記ということのようですが
"3"および"4"のフィルタリング結果は転記してますけど、"5" と "6" についてはフィルタリングして
コピーはしているものの、どこにもペーストしていませんね。
その理由は？

で、本題のメモリーオーバ。
これぐらいでメモリーオーバーはしないとは思いますが、コピー・ペースト（あるいはコピーのみ）を
繰り返していますね。でも、コピーモードの解除はしていませんので、どんどんクリップボードにため込まれる？
そのあたりが原因かもしれません。

Paste:=xlPasteValues　で値貼り付けをしているようですけど、フルコピー（いわゆるコピペ）では具合悪いですか？

ところで、このシートのレイアウト、正確なところを教えていただけませんか。
特に何列目まであるのかという部分。
【77828】Re:メモリ不足の解消の仕方
発言  β  - 16/1/6(水) 20:59 -
引用なし
パスワード
   ▼YUKI さん：

とにかく、コメントしている通りよくわかりませんが、だめもとで。
"5" と "6" の転記先がわからないので適当にしておきました。

Sub 貼り付け()
　　Dim i As Integer
　　Dim shF As Worksheet
'
'
'
　　Application.ScreenUpdating = False
　　
'　　On Error Resume Next　 '何のためのコードですか？？


　　For i = 16 To 30

　　　　With Sheets(i)
　　　　　　Set shF = Sheets(i - 15)
　　　　　　.AutoFilterMode = False
　　　　　　.Range("A1", .UsedRange).Offset(40).AutoFilter
　　　　　　'3
　　　　　　.AutoFilter.Range.AutoFilter Field:=8, Criteria1:="3"
　　　　　　If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
　　　　　　　　.AutoFilter.Range.Copy shF.Range("A35")
　　　　　　End If
　　　　　　
　　　　　　'4
　　　　　　.AutoFilter.Range.AutoFilter Field:=8, Criteria1:="4"
　　　　　　If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
　　　　　　　　.AutoFilter.Range.Copy shF.Range("Q35")
　　　　　　End If
　　　　　　'5
　　　　　　.AutoFilter.Range.AutoFilter Field:=8, Criteria1:="5"
　　　　　　If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
　　　　　　　　.AutoFilter.Range.Copy shF.Range("AG35")
　　　　　　End If
　　　　　　'6
　　　　　　.AutoFilter.Range.AutoFilter Field:=8, Criteria1:="6"
　　　　　　If .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
　　　　　　　　.AutoFilter.Range.Copy shF.Range("AW35")
　　　　　　End If
　　　　　　.AutoFilterMode = False
　　　　End With
　　　　
　　　　DoEvents
　　Next
　　'
　　'
'　　Erase DynamicArray
　　Sheets(16).Select
　　Application.ScreenUpdating = True

End Sub
【77829】Re:メモリ不足の解消の仕方
お礼  YUKI  - 16/1/7(木) 15:24 -
引用なし
パスワード
   ▼β 様
お返事遅くなりまして申し訳ありません。
書いていただいたコードを動作させて見た所、
思い描くとおりの結果になりました。
処理もものすごく早くなりました。ありがとうございます！

まだまだ勉強しながらの手探りから脱却できませんが
教えていただいた事を少しづつ理解できるように努力します。
ありがとうございました
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
872 / 13645 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free