Excel VBA質問箱 IV

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

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


17849 / 76732 ←次へ | 前へ→

【64329】処理が重い
質問  tetu  - 10/1/30(土) 18:26 -

引用なし
パスワード
   ExcelにてCSVファイルを取込で計画数を処理するマクロをくんでいます
65536行ふるに使うとどうしても処理が固まり動かなくなります
どのようにしたらいいかわかるかたおしえてください。
///////////////ボタン1で下記プログラムが動く
Sub 取込()


Application.ScreenUpdating = False '画面の移動停止

Dim vri As Variant 'Vriをvariant型で宣言(メモリー格納)


 vri = Application.GetOpenFilename( _
   Filefilter:="テキストファイル,*.csv,", _
     Title:="他のファイルを開く", _
      MultiSelect:=False)
 'ファイルを開く処理
If vri = False Then
   MsgBox "ファイルは選択されませんでした。", _
    vbOKOnly + vbExclamation, "ファイル名の入力チェック"
    Exit Sub
    'ファイルが選択されない場合エラーメッセージ処理する
Else
   Workbooks.Open (vri)
   '選ばれた場合は選択したCSVファイルを開く
End If
 
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
  Selection.Copy           'CSVファイルのデータ選択してコピー
   Windows("進度.xls").Activate '進度xlsに移動
    Sheets("データ取込").Select  '(データ取込)シートに移動
     Range("A1").Select      'セルA1を選択してデータを貼り付け処理する
      ActiveSheet.Paste


Union(Columns("A"), Columns("C:d"), Columns("F"), _
   Columns("I"), Columns("K")).Select
     Selection.Delete
     '選択した列(不要なデータ)を削除する
Range("F1").Activate 'セルF1に移動する
With Range("F1") 'F1に対しての処理(Withステートメントの開始)
  .FormulaR1C1 = "=RC[-1]&RC[-4]" '文字連結
  .AutoFill Destination:=Range("F1", Range("E" & Rows.Count).End(xlUp).Offset(, 1)), _
   Type:=xlFillDefault
  '指定行までオートフィルする
End With '(Withステートメントの終了)
Range("F1", Range("F65536").End(xlUp)).Select
     Selection.Copy  '文字連結したセルを選択してコピーする
   
Range("G1").Activate 'G1へ移動
 Selection.PasteSpecial Paste:=xlPasteValues '値のみ貼り付け
      
Range("H1").Activate 'H1へ移動
ActiveCell.FormulaR1C1 = "=TRIM(RC[-1])" 'TRIM関数で文字間の不要なスペースを削除
ActiveCell.AutoFill Destination:=Range("H1", Range("G" & Rows.Count).End(xlUp).Offset(, 1)), _
   Type:=xlFillDefault  '指定行までオートフィルする
       
Range("H1", Range("H" & Rows.Count).End(xlUp)).Select
 Selection.Copy '指定行まで、コピー
   Range("I1").Activate 'セルI1へ移動
    Selection.PasteSpecial Paste:=xlPasteValues 'コピーした値を貼り付ける
    

Union(Columns("B"), Columns("E:H")).Select
  Selection.Delete '指定列を削除
  
Range("A1").Activate  'A1セルに移動

  
Range("A1").CurrentRegion.Select '文字入力されている範囲を選択


Columns("A:D").Select '列 A〜Eを選択

Columns("A").Select '列Aを選択する
 Selection.Insert '列Aを挿入する
  Columns("E").Select
   Selection.Copy '列Dを選択してコピーする。
Columns("A").Select 'A列を選択


 Selection.PasteSpecial Paste:=xlPasteValues '貼り付ける
   Application.CutCopyMode = False 'コピー処理を中止する
Columns("E").Select
  Selection.Delete '列Eを選択して削除する。


 Columns("B").Select '列Bを選択
 Selection.Copy 'B列をコピー
 Range("E1").Select 'セルE1を選択
 Selection.PasteSpecial 'B列の値を貼り付け
 Columns("B").Delete 'B列を選択
Range("A1", Range("D" & Rows.Count).End(xlUp)).Select

 
 Selection.Copy '選択したセルをコピーする
 
  Sheets("展開").Activate 'シート("展開")に移動
 If Sheets("展開").Range("A1") = "" Then  'A1が空白なら下記処理を実行
   Range("A1").Select  'セルA1を選択
    Selection.PasteSpecial Paste:=xlPasteValues '値のみ貼り付け
    
 Else
    Sheets("展開").Range("A1").End(xlDown).Offset(1, 0).Select '最終行を選択
     Selection.PasteSpecial    '値を貼り付け
    
    Columns("A:D").Select  '列A〜Cを選択
   
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
    
    '品番、納期の順番で昇順に並べ替える
     
    
 End If
 
    
      Application.CutCopyMode = False
      'コピーする処理を中止する
      Columns("B").Select '列Bを選択
       Selection.NumberFormatLocal = "yyyy/m/d" '日付形式に変換
       
     Sheets("メニュー画面").Activate 'メニュー画面に戻る
      Application.ScreenUpdating = True '画面の移動実行
     
     MsgBox "データ取込終了" '取込み終了メッセージ


End Sub
///////ボタン2で下記プログラムが動くこちらで止まる
Sub Ver2maedaosi()
'
' Ver2maedaosi Macro
' マクロ記録日 : 2010/1/30 ユーザー名 : 加藤 鉄也
'

'
Application.ScreenUpdating = False '画面の移動停止
  Sheets("展開").Select 'シート展開を選択
  Columns("B:B").Select '列Bを選択
  Selection.Insert Shift:=xlToRight '右方向に挿入
  Columns("D:D").Select 'D列を選択
  Selection.Insert Shift:=xlToRight '右方向に選択
  Columns("A:A").Select '列Aを選択
  Selection.Copy '列Aに貼り付け
  Columns("B:B").Select '列Bを選択
  ActiveSheet.Paste '貼り付け
  Application.CutCopyMode = False '貼り付けモードをやめる
  Columns("C:C").Select '列Cを選択
    Selection.Copy ' 列Cをコピー
  Columns("D:D").Select ' 列Dを選択
  ActiveSheet.Paste '貼り付け
  Application.CutCopyMode = False '貼り付けモードをやめる
  Range("G1").Select 'G1を選択
  
  ActiveCell.FormulaR1C1 = "=RC[-6]&""_""&RC[-4]" '関数を入力品番と納期を連結
  Selection.AutoFill Destination:=Range("G1").Resize(Range("A65536").End(xlUp).Row), Type:=xlFillDefault
  ' 関数をオートフィルして式をデータがあるところまで入力
 
 
  Range("H1").Select '列H1を選択
  ActiveCell.FormulaR1C1 = _
    "=IF((RC[-7]:R[443]C[-7]=RC[-6])*(RC[-5]:R[443]C[-5]=RC[-4])*COUNTIF(RC[-1]:R1C[-1],RC[-1])>1,"""",RC[-5])"
  Selection.AutoFill Destination:=Range("H1").Resize(Range("A65536").End(xlUp).Row), Type:=xlFillDefault
  ' 関数を入力配列として条件を出して納期の重複行を空白しデーター範囲までアートフィルする
  Columns("H:H").Select '列Hを選択
  
  Range("I1").Select 'セルI1を選択
  Selection.FormulaArray = _
    "=SUM(IF((RC[-8]:R[443]C[-8]=RC[-7])*(RC[-6]:R[443]C[-6]=RC[-5]),RC[-4]:R[443]C[-4]),)"
  '関数を配列として条件をだして同じ納期なら計画数を合計しデーター範囲までアートフィルする
  Selection.AutoFill Destination:=Range("I1").Resize(Range("A65536").End(xlUp).Row), Type:=xlFillDefault
  
  Columns("F:F").Select '列Fを選択
  Selection.Copy     '列Fをコピー
  Columns("J:J").Select '列Jを選択
  ActiveSheet.Paste    '列Jに貼り付け
  Application.CutCopyMode = False '貼り付け状態を中止
  Union(Columns("A"), Columns("H:J")).Select '列AとH~J列を選択
  Selection.Copy 'コピーする
  Columns("K:N").Select '列K~Nを選択
  Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False '値を貼り付け
  Columns("K:N").EntireColumn.AutoFit '列K~Nの列調整
  Application.CutCopyMode = False
  
  Columns("L:L").EntireColumn.AutoFit '列Lの幅調整
  Columns("K:K").EntireColumn.AutoFit '列Kの幅調整
  Columns("N:N").EntireColumn.AutoFit '列Nの幅調整
  
  Range("A:j").Select 'セルA~Jを選択
  Selection.Delete '削除
  Columns("A:D").Select '列A~Dを選択
  Selection.AutoFilter
  Selection.AutoFilter Field:=2, Criteria1:="<>" 'オートフィルターで空白以外のセルを絞り込む
  Columns("A:D").Select '列A~Dを選択
  Selection.Copy 'コピーする
  Range("E1").Select 'セルE1を選択
  Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False '貼り付け
  Selection.AutoFilter Field:=2
  Application.CutCopyMode = False '貼り付け状態中止
  Selection.AutoFilter 'フィルター解除
  Columns("A:D").Select '列A~Dを選択
  
  Range("D1").Activate 'セルD1を選択
  Selection.Delete Shift:=xlToLeft '右方向に削除
  Columns("B:B").Select '列Bを選択
  Selection.NumberFormatLocal = "yyyy/m/d" ' 日付け形式に変更
  Sheets("メニュー画面").Select 'メニュー画面を選ぶ
  Application.ScreenUpdating = True '画面の移動実行
  
   MsgBox " 追加処理終了" 'メッセージ画面表示
  
End Sub
他にボタン3,4とありますがこちらは問題ないので省略します


ボタン2で固まりますやはりシートを分けた方がいいのでしょうか・・・?
OS Widows98SE
EXCEl2000
よろしくおねがいします。

0 hits

【64329】処理が重い tetu 10/1/30(土) 18:26 質問
【64330】Re:処理が重い かみちゃん 10/1/30(土) 18:32 発言
【64376】Re:処理が重い tetu 10/1/31(日) 23:18 お礼
【64331】Re:処理が重い Hirofumi 10/1/30(土) 20:07 発言
【64335】Re:処理が重い Hirofumi 10/1/31(日) 0:26 発言
【64337】Re:処理が重い tetu 10/1/31(日) 2:32 発言
【64341】Re:処理が重い Hirofumi 10/1/31(日) 9:13 回答
【64344】Re:処理が重い Hirofumi 10/1/31(日) 9:44 発言
【64377】Re:処理が重い tetu 10/1/31(日) 23:27 質問
【64379】Re:処理が重い Hirofumi 10/2/1(月) 8:03 回答
【64411】Re:処理が重い tetu 10/2/4(木) 1:56 質問
【64416】Re:処理が重い Hirofumi 10/2/4(木) 11:54 回答
【64471】Re:処理が重い tetu 10/2/11(木) 1:12 質問
【64473】Re:処理が重い Hirofumi 10/2/11(木) 9:49 回答
【64372】Re:処理が重い よろずや 10/1/31(日) 20:55 発言
【64378】Re:処理が重い tetu 10/1/31(日) 23:29 お礼
【64380】Re:処理が重い Jaka 10/2/1(月) 9:19 発言
【64412】Re:処理が重い tetu 10/2/4(木) 2:00 お礼
【64413】Re:処理が重い かみちゃん 10/2/4(木) 6:25 発言
【64470】Re:処理が重い tetu 10/2/11(木) 0:23 お礼

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