[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ループしっ放しで「完了」とならない』（しゅう）
このコード↓だと数分で「完了」となりますが、その下のコードだと一晩置いてもループしっ放しになります。原因が判りません。何が考えられるでしょうか？
教えてください。よろしくお願いいたします。
Sub ?@データ取得()
'
' データ取得 Macro
' マクロ記録日 : 2011/9/13 ユーザー名 : メカ部
'
Worksheets("Ｍ").EnableCalculation = False '再計算しない
Worksheets("Ｊ").EnableCalculation = False
Worksheets("Sheet1").Select
Range("F1").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("a2:e20000").Select
Selection.ClearContents
Range("a1").Select
iB = 1
Do While Cells(iB + 1, "F").Value <> ""
Cells(iB + 1, "A").Value = Cells(iB + 1, "N").Value & Cells(iB + 1, "L").Value & Cells(iB + 1, "K").Value & Cells(iB + 1, "H").Value
Cells(iB + 1, "B").Value = Cells(iB + 1, "N").Value & Cells(iB + 1, "L").Value & Cells(iB + 1, "H").Value
Cells(iB + 1, "C").Value = Val(Cells(iB + 1, "J").Value) * Val(Cells(iB + 1, "O").Value) / 12
Cells(iB + 1, "D").Value = Val(Cells(iB + 1, "I").Value) * Val(Cells(iB + 1, "O").Value) / 12
iB = iB + 1
If iB = 40000 Then Exit Do
Loop
Worksheets("Ｍ").EnableCalculation = True '再計算する
Worksheets("Ｊ").EnableCalculation = True
MsgBox "データ更新しました"
End Sub
_____________＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿
Sub ?@データ取得()
'
' データ取得 Macro
' マクロ記録日 : 2011/9/13 ユーザー名 : Ｍ部
'
Worksheets("Ｍ").EnableCalculation = False '再計算しない
Worksheets("Ｊ").EnableCalculation = False
Worksheets("Sheet1").Select
Range("F1").Select
Selection.QueryTable.Refresh BackgroundQuery:=False
Range("a2:e20000").Select
Selection.ClearContents
Range("a1").Select
Ｎ修正
iB = 1 Do While Cells(iB + 1, "F").Value <> ""
Cells(iB + 1, "A").Value = Cells(iB + 1, "N").Value & Cells(iB + 1, "L").Value & Cells(iB + 1, "K").Value & Cells(iB + 1, "H").Value
Cells(iB + 1, "B").Value = Cells(iB + 1, "N").Value & Cells(iB + 1, "L").Value & Cells(iB + 1, "H").Value
Cells(iB + 1, "C").Value = Val(Cells(iB + 1, "J").Value) * Val(Cells(iB + 1, "O").Value) / 12
Cells(iB + 1, "D").Value = Val(Cells(iB + 1, "I").Value) * Val(Cells(iB + 1, "O").Value) / 12
iB = iB + 1
If iB >= 10000 Then Exit Do
Loop
Worksheets("Ｍ").EnableCalculation = True '再計算する
Worksheets("Ｊ").EnableCalculation = True
MsgBox "データ更新しました"
End Sub
Sub Ｎ修正()
iB = 1
Do While Cells(iB + 1, "F").Value <> ""
If Cells(iB + 1, "N").Value = "KK7" And Cells(iB + 1, "K").Value = "9035" Then Cells(iB + 1, "K").Value = "9047"
iB = iB + 1
If iB = 10000 Then Exit Do
Loop
End Sub
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
ループが抜けられないわけではないのでデータが重すぎるか画面更新で容量が増えてるかかと思います
Application.ScreenUpdating = False
条件
Application.ScreenUpdating = True
これを追加でどうでしょう
（とらねこ） 2015/02/27(金) 10:55
シートのチェンジイベントとかもあるかも？
テストしてないけど、書き換えるとこんな感じ？
Sub データ取得()
Dim iB As Long
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
With Worksheets("Sheet1")
'Selection.QueryTable.Refresh BackgroundQuery:=False
.Range("a2:e20000").ClearContents
iB = 2
Do While .Cells(iB, "F").Value <> ""
.Cells(iB, "A").Value = ConTxt(.Name, iB, "N", "L", "K", "H")
.Cells(iB, "B").Value = ConTxt(.Name, iB, "N", "L", "H")
.Cells(iB, "C").Value = ConVal(.Name, iB, "J", "D") / 12
.Cells(iB, "D").Value = ConVal(.Name, iB, "I", "O") / 12
iB = iB + 1
If iB = 40000 Then Exit Do
Loop
End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "データ更新しました"
End Sub
Private Function ConTxt(ByVal shn As String, i As Long, ParamArray C()) As String
Dim x
With Sheets(shn)
For Each x In C
ConTxt = ConTxt & .Cells(i, x).Value
Next x
End With
End Function
Private Function ConVal(ByVal shn As String, i As Long, ParamArray C()) As Double
Dim x
ConVal = 1
With Sheets(shn)
For Each x In C
ConVal = ConVal * .Cells(i, x).Value
Next x
End With
End Function
（稲葉） 2015/02/27(金) 11:03
まず、どらねこさんの追加で試したのですが「コンパイルエラー」が出ました。
End Subの次の行に書き足すだけではダメなのでしょうか？
無知すぎてすみません。
（しゅう） 2015/02/27(金) 13:16
コンパイルエラーは私のほうですね。 やっぱりテストだけでもしておくべきだった・・・ 差し替えましたので、確認してください。 （稲葉） 2015/02/27(金) 13:51
下から失礼しますが、 >「コンパイルエラー」が出ました。 は別件では？
> End Subの次の行に書き足すだけではダメなのでしょうか？ End Sub の次に書き足してはダメです。
基本的にコードは Sub ・・・ ・・・ End Sub の中に書いてください。 外に書いていいのはオプションと変数と参照の宣言くらいです。
位置は稲葉さんのコメントのコードを参照ください。
（Mook） 2015/02/27(金) 13:54
'動かしたいマクロ内容 Application.ScreenUpdating = True End Sub
このように書いてください
"エクセル マクロ 画面更新"
などで検索すると参考になるページがたくさん出てきますよ
（とらねこ） 2015/02/27(金) 14:08
記念参加で。
Sub データ取得()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Worksheets("Sheet1").Activate
Range("A2:E10000").ClearContents
If Range("F2").Value = "" Then Exit Sub
Dim データ最終行 As Long
データ最終行 = Application.Min(10000, Range("F1").End(xlDown).Row) '// 空白で終了なので xlDown で
Dim 結果データ
結果データ = Range("A1").Resize(データ最終行, 4) '// A列(1)〜D列(4)
Dim 修正データ
修正データ = Range("K1").Resize(データ最終行, 1) '// K列(1)
Dim 作業データ
作業データ = Range("H1").Resize(データ最終行, 8) '// H列(1)〜O列(8) : H(1) I(2) J(3) K(4) L(5) M(6) N(7) O(8)
Dim r As Long
For r = 2 To データ最終行
If 作業データ(r, 7) = "KK7" And 作業データ(r, 4) = "9035" Then '// 修正処理
作業データ(r, 4) = "9047"
修正データ(r, 1) = "9047"
End If
結果データ(r, 1) = 作業データ(r, 7) & 作業データ(r, 5) & 作業データ(r, 4) & 作業データ(r, 1)
結果データ(r, 2) = 作業データ(r, 7) & 作業データ(r, 5) & 作業データ(r, 1)
結果データ(r, 3) = Val(作業データ(r, 3)) * Val(作業データ(r, 8)) / 12
結果データ(r, 4) = Val(作業データ(r, 1)) * Val(作業データ(r, 8)) / 12
Next
Range("A1").Resize(データ最終行, 4) = 結果データ
Range("K1").Resize(データ最終行, 1) = 修正データ
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "データ更新しました"
End Sub
（Mook） 2015/02/27(金) 15:57
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.