人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルについての質問です。少しややこしいので200ポイント差し上げます。

プログラムの動作が遅いので改善して下さい。


ばらばらに並んだ同一文字列のある行を、同じ文字列を持つ行の下にそろえるプログラムです。

例えば

1234 re
2345 rt
3456 ty
2345 ty
1234 5t

を一列目でそろえると、

1234 re
1234 5t
2345 rt
2345 ty
3456 ty

となるプログラムです。

次のプログラムを作成しました。しかし5000行に対して実行したところ

Selection.Insert Shift:=xlDown

で異常に遅い(1つ挿入するのに10秒以上)かかります。

どこがおかしいのでしょうか?
修正していただけるとありがたいです。


Sub irekae()
i = 1
Do Until Cells(i, 5) = ""
cnt = 1
j = i + 1
Do Until Cells(j, 5) = ""
If Cells(i, 5) = Cells(j, 5) Then
Rows(j & ":" & j).Select
Selection.Cut
Rows(i + cnt & ":" & i + cnt).Select
Selection.Insert Shift:=xlDown
cnt = cnt + 1
End If
j = j + 1
Loop
i = i + cnt
Loop
End Sub

●質問者: ReoReo7
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:CNT LOOP SELECT sub エクセル
○ 状態 :終了
└ 回答数 : 7/7件

▽最新の回答へ

1 ● Gazebo
●20ポイント

最初に、描画を止めるだけでも高速になりますよ。

すでにされているのでしたらごめんなさい。

Sub irekae()

'描画停止

Application.ScreenUpdating = False

(ぷろぐらむ)

'描画再開

Application.ScreenUpdating = True

End Sub

◎質問者からの返答

ありがとうございます。試してみます。どうやら表示ではなく、セルの並び替え時に再計算が必要なのが原因なようです。


2 ● tikirou
●20ポイント

修正してみました。

1.変数は型宣言する

2.画面の描写は止める

3.SELECTは使わない

今、ちょっと動作できる環境がないので

実は動くかわかりません・・・・。

Sub irekae()

Dim i As Integer, j As Integer, cnt As Integer

Application.ScreenUpdating = False

i = 1

Do Until Cells(i, 5) = ""

cnt = 1

j = i + 1

Do Until Cells(j, 5) = ""

If Cells(i, 5) = Cells(j, 5) And (i + 1 <> j) Then

Rows(j).Cut

Rows(i + cnt).Insert Shift:=xlDown

cnt = cnt + 1

End If

j = j + 1

Loop

i = i + cnt

Loop

Application.ScreenUpdating = True

◎質問者からの返答

どうもありがとうございます。参考にさしていただきます。


3 ● りくっち
●60ポイント ベストアンサー

修正案でなくて恐縮なのですが、

という作業でよいのならということで並び替え機能を使ったやり方を一案。

基本的にカット&ペーストはメモリを食うので、動作が遅くなりがちですし。

処理したい範囲の左上にカーソルをセット(A1:B5ならA1にカーソルを置いて)してマクロ実行してください。

(該当範囲の選択に関しては、作業シートの状態によっては別コードにした方がいいかもしれませんが)

ちなみに↓のコードはB列にも昇順かけているので、

不要の場合は「Key2?」の行を削除してください。


Sub narabikae()

 Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
 Selection.Sort _
 Key1:=Range("A1"), Order1:=xlAscending, _
 Key2:=Range("B1"), Order2:=xlAscending, _
 Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
 Orientation:=xlTopToBottom, _
 SortMethod:=xlPinYin, DataOption1:=xlSortNormal, _
 DataOption2:=xlSortNormal
End Sub
◎質問者からの返答

使用しましたが、非常に有効に動きました。ありがとうございました。


4 ● たか
●0ポイント

10行目の判定時、1?9行目に同じ文字がないか?でいいのに、このマクロでは

10行目でも1?5000行目に同じ文字がないか?となっています


Sub irekae()

For x = 2 To 5000

If Cells(x, 1) = "" Then Exit For

a = Cells(x, 1)

For y = 1 To x

z = x - y

If z = 0 Then Exit For

If Cells(x, 1) = Cells(z, 1) Then

If (z + 1 = x) Then Exit For

Rows(x & ":" & x).Select

Selection.Cut

Rows(z + 1 & ":" & z + 1).Select

Selection.Insert shift:=xlDown

End If

Next

Next

End Sub

5000行で試しましたが、1行1秒も掛かりませんでした

サッと終わるものでもないですが・・・

◎質問者からの返答

そういう間違いがあるのですね。ありがとうございました。


5 ● たか
●50ポイント

Sub irekae()

For x = 2 To 5000

If Cells(x, 1) = "" Then Exit For

a = Cells(x, 1)

For y = 1 To x

z = x - y

If z = 0 Then Exit For

If Cells(x, 1) = Cells(z, 1) Then

If (z + 1 = x) Then Exit For

Rows(x & ":" & x).Select

Selection.Cut

Rows(z + 1 & ":" & z + 1).Select

Selection.Insert shift:=xlDown

Exit For

End If

Next

Next

End Sub

◎質問者からの返答

了解です


1-5件表示/7件
4.前の5件|次5件6.
関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ