| |
ExcelにてCSVファイルを取込で計画数を処理するマクロをくんでいます
６５５３６行ふるに使うとどうしても処理が固まり動かなくなります
どのようにしたらいいかわかるかたおしえてください。
///////////////ボタン１で下記プログラムが動く
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
///////ボタン２で下記プログラムが動くこちらで止まる
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 'セルI１を選択
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とありますがこちらは問題ないので省略します
ボタン２で固まりますやはりシートを分けた方がいいのでしょうか・・・？
OS Widows98SE
EXCEl2000
よろしくおねがいします。
|
|
tetu
- 10/1/30(土) 18:26 -
