Excel VBA質問箱 IV

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

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


871 / 13644 ツリー ←次へ | 前へ→

【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 -

引用なし
パスワード
   ▼β 様
お返事遅くなりまして申し訳ありません。
書いていただいたコードを動作させて見た所、
思い描くとおりの結果になりました。
処理もものすごく早くなりました。ありがとうございます!

まだまだ勉強しながらの手探りから脱却できませんが
教えていただいた事を少しづつ理解できるように努力します。
ありがとうございました

871 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free