Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10 Pro : その他)
デバックモードではできるのに実行時には正しく動作しない
投稿日時: 21/06/03 17:07:53
投稿者: あきこさん

Excel for office365利用です。
 
「1行目に入力した関数を、最下行までコピーする」という単純な作業が、VBA実行時では最下行までいかず、doeventを挿入、screen update の切り替えを行っても解決できずにおります。
 
 
 
以下一部省略して記載いたします。
 
 
Option Explicit
Dim lastrow As Long
 
Sub PIC_main_W()
 Range("a4").Select
 lastrow = Cells(Rows.Count, 1).End(xlUp).Row
(途中省略)
 ActiveCell.FormulaR1C1 = "(ifで4分岐させたVLOOKUPの数式)"
 ActiveCell.Offset(0, 1).FormulaR1C1 = "(ifで4分岐させたVLOOKUPの数式)"
 ActiveCell.Offset(0, 3).FormulaR1C1 = "(ifで4分岐させたVLOOKUPの数式)"
 ActiveCell.Offset(0, 4).FormulaR1C1 = "(ifで4分岐させたVLOOKUPの数式)"
 
'2行目以下に数式コピペ&値貼付け
 Range(ActiveCell, ActiveCell.Offset(0, 4)).Select
 Selection.Copy
 
Application.ScreenUpdating = True 'Excel側に画面強制更新の依頼。
VBA.DoEvents 'Excelが画面更新できるように、処理を手放す。
 
 Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(lastrow - 4, 4)).Select
 
Application.ScreenUpdating = True 'Excel側に画面強制更新の依頼。
VBA.DoEvents 'Excelが画面更新できるように、処理を手放す。
 
 ActiveSheet.Paste
     
 '値貼り付けの代わり
 Range(ActiveCell, ActiveCell.Offset(lastrow - 4, 4)).Value = Range(ActiveCell, ActiveCell.Offset(lastrow - 4, 4)).Value
 
End Sub
 
 
 
変数のlastrowを見てみると、きちんと最下行の行番号をキャッチできていました。
しかし、実際に実行してみると、毎回最下行まで数式がいけておらず(処理のたびに、どこで止まるかは異なります。
そのまま値貼り付けして→プロシージャの実行終了してしまっており、
DOEVENTSの効果が無いようにみえます。
 
これ以上どうすればよいのかわからず、ご意見、アドバイス頂戴したいです。
宜しくお願いいたします。

回答
投稿日時: 21/06/03 20:50:18
投稿者: simple

一部分の提示かもしれないので、原因は不明です。
コピーペイストなどには 基本的に DoEventsなどは不要だと思います。
 
ActiveCellを多用するのはちょっと私の趣味に合わないです。
私だったら、たぶんこんな書き方をします。参考にして下さい。
 

Sub PIC_main_W()
    Dim lastrow     As Long
    Dim rng         As Range
    Dim targetRng   As Range
    
    lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = Range("A4")
    
    '(途中省略)
    rng.FormulaR1C1 = "(ifで4分岐させたVLOOKUPの数式)"
    rng.Offset(0, 1).FormulaR1C1 = "(ifで4分岐させたVLOOKUPの数式)"
    rng.Offset(0, 3).FormulaR1C1 = "(ifで4分岐させたVLOOKUPの数式)"
    rng.Offset(0, 4).FormulaR1C1 = "(ifで4分岐させたVLOOKUPの数式)"

    Set targetRng = Range(rng, Cells(lastrow, "E"))
    rng.Resize(1, 5).Copy targetRng
    targetRng.Value = targetRng.Value
End Sub

回答
投稿日時: 21/06/03 21:16:44
投稿者: simple

そのワークシートには、イベントプロシージャが組み込んであるとか、
何か特別の条件があるなら、それらをキチンと示してくださいね。
 
過去ログでは、画像のコピー貼付処理において、
画像のレンダリングが追いつかないことがあったようで、
それでDoEventsを使ったようですが、
計算式について、そういうことは不要だと思います。
 
それはExcelの基本的な機能であって、それができないなら、
表計算ソフトの看板を下ろしてもらわないといけない。
また、余りそういう話は聞いたことがありません。
何かしら別の要因だと思います。

回答
投稿日時: 21/06/03 21:27:04
投稿者: simple

追記です。
 
もし、そのシートに計算式が大量にあり、更新に伴って、
再計算が起きることが負担になっているとすれば、
処理の冒頭で、

    Application.Calculation = xlCalculationManual
と手動計算にしておき、
処理の最後に
    Application.Calculation = xlCalculationAutomatic
とすることが考えられます。
(これは速度向上の一般的な手法です。)

回答
投稿日時: 21/06/03 22:25:20
投稿者: WinArrow
投稿者のウェブサイトに移動

Lastrowがあるということは、ループ処理がありますよね?
データ件数は、何件くらいですか?
 
セルへのアクセスは、時間が掛かり効率が悪い。
とにかく、
Activecell
や、
セルのSelect
はやめるべき
DoEventsは無意味だと思います。
これで、レスポンスは改善されると思います。

投稿日時: 21/06/03 23:46:25
投稿者: あきこさん

WinArrowさん、simpleさん
ありがとうございます。
 
数式の場合はDoEventsでは解決しえないこと、activecellやselectの多用はよろしくないことを知れて、目から鱗が落ちる思いです。
 
ご指摘くださった通り、数千〜7万行に及ぶシート4枚が数式で繋がってしまっています。
Office365になってVLLOKUPが高速化したことにより、胡坐をかいていたと反省しました。
 
計算式を一時手動にすること、activecellやselectを減らすよう、コードを修正してみます。
 
 
一部省略してしまったことでかえって問題の本質を分かりにくくさせてしまい、申し訳ありませんでした。
全体は以下のとおりでした。
 
Option Explicit
 
Dim lastrow As Long
Dim lastclm As Long
Dim WH As Worksheet, WB As Workbook, flag As Boolean
 
 
Sub PIC_main_W()
 
'画面固定
'Application.ScreenUpdating = False
 
'対象ファイルをアクティブにしてVlookupに飛ぶ
'見つからなかったら終了
For Each WB In Workbooks
    If WB.Name Like "*_?M*.xlsb" Then
        flag = True
        WB.Activate
        PIC_vlookup_W
    End If
Next
 
    If flag = True Then
        MsgBox ("Finished.")
    Else
        MsgBox ("''hoge file'' is not found.")
    End If
 
'画面固定解除
'Application.ScreenUpdating = True
 
End Sub
 
Sub PIC_vlookup_W()
 
  'フィルタがあればフィルタを全件表示へ
    For Each WH In Worksheets
        If WH.FilterMode Then
            WH.ShowAllData
        End If
    Next WH
 
 
'テーブルは解除する
Dim ls As ListObject
For Each WH In Worksheets
    For Each ls In WH.ListObjects
      ls.Unlist
    Next ls
Next WH
 
 
 
'文字列になっているので直す
Columns("AC:AK").Select
Selection.NumberFormatLocal = "#,##0_ "
 
 
'最終行と最終列を取得
Range("a4").Select
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
lastclm = Cells(4, Columns.Count).End(xlToLeft).Column
 
 
'計算の起点となるセルへ移動
Cells(4, lastclm + 1).Select
 
'Set myRange = ActiveCell
 
 
'タイトルをつける
ActiveCell.Offset(-1, 0) = "Main contact person"
ActiveCell.Offset(-1, 1) = "Main Mail"
ActiveCell.Offset(-1, 2) = "Sub Contact person"
ActiveCell.Offset(-1, 3) = "Sub Mail"
ActiveCell.Offset(-1, 4) = "Department"
 
 
'最初の行に数式を入れる(計5セル)
ActiveCell.FormulaR1C1 = _
        "=IF(RC2=""aaa"",VLOOKUP(RC2&RC12,'hoge.xlsb'!forAAA[#Data],5,0),IF(RC2=""bbb"",VLOOKUP(RC2&RC12,'hoge.xlsb'!forBBB[#Data],4,0),IF(RC2=""ccc"",VLOOKUP(RC2&RC12,'hoge.xlsb'!forCCC[#Data],4,0),VLOOKUP(RC2&RC12,'hoge.xlsb'![#Data],5,0))))"
 
ActiveCell.Offset(0, 1).FormulaR1C1 = _
        "=IF(RC2=""aaa"",VLOOKUP(RC2&RC12,'hoge.xlsb'!forAAA[#Data],6,0),IF(RC2=""bbb"",VLOOKUP(RC2&RC12,'hoge.xlsb'!forBBB[#Data],5,0),IF(RC2=""ccc"",VLOOKUP(RC2&RC12,'hoge.xlsb'!forCCC[#Data],5,0),VLOOKUP(RC2&RC12,'hoge.xlsb'![#Data],6,0))))"
           
ActiveCell.Offset(0, 2).FormulaR1C1 = _
        "=IF(RC2=""aaa"",VLOOKUP(RC2&RC12,'hoge.xlsb'!forAAA[#Data],7,0),VLOOKUP(RC2&RC12,'hoge.xlsb'![#Data],7,0))"
     
ActiveCell.Offset(0, 3).FormulaR1C1 = _
        "=IF(RC2=""aaa"",VLOOKUP(RC2&RC12,'hoge.xlsb'!forAAA[#Data],7,0),IF(RC2=""bbb"",VLOOKUP(RC2&RC12,'hoge.xlsb'!forBBB[#Data],6,0),IF(RC2=""ccc"",VLOOKUP(RC2&RC12,'hoge.xlsb'!forCCC[#Data],6,0),VLOOKUP(RC2&RC12,'hoge.xlsb'![#Data],7,0))))"
 
ActiveCell.Offset(0, 4).FormulaR1C1 = _
        "=IF(RC2=""aaa"",VLOOKUP(RC2&RC12,'hoge.xlsb'!forAAA[#Data],4,0),VLOOKUP(RC2&RC12,'hoge.xlsb'![#Data],4,0))"
 
'2行目以下に数式コピペ&値貼付け
Range(ActiveCell, ActiveCell.Offset(0, 4)).Select
    Selection.Copy
 
Application.ScreenUpdating = True 'Excel側に画面強制更新の依頼。
VBA.DoEvents 'Excelが画面更新できるように、処理を手放す。
 
 
 
Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(lastrow - 4, 4)).Select
 
 
 
Application.ScreenUpdating = True 'Excel側に画面強制更新の依頼。
VBA.DoEvents 'Excelが画面更新できるように、処理を手放す。
 
 
 
ActiveSheet.Paste
     
'値貼り付けの代わり
Range(ActiveCell, ActiveCell.Offset(lastrow - 4, 4)).Value = Range(ActiveCell, ActiveCell.Offset(lastrow - 4, 4)).Value
        
     
'1行目の数式も値貼付け
Range(ActiveCell.Offset(-1, 0), ActiveCell.Offset(-1, 4)).Select
'ActiveSheet.Paste
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
   
End Sub

回答
投稿日時: 21/06/04 06:25:43
投稿者: simple

Sub PIC_vlookup_W()の中ではActiveworkbookを対象に実行するようですが、
どのシートに対して実行するかは、明示的に指定していないように見えます。
そこは大丈夫ですか?

投稿日時: 21/06/04 16:06:57
投稿者: あきこさん

Simpleさん
 

引用:
Sub PIC_vlookup_W()の中ではActiveworkbookを対象に実行するようですが、
どのシートに対して実行するかは、明示的に指定していないように見えます。
そこは大丈夫ですか?

 
 
ありがとうございます。対象WORKBOOKである"*_?M*.xlsb"は
シートが1枚しかないため、シートを指定していませんでした。

回答
投稿日時: 21/06/04 17:55:51
投稿者: simple

ああそうですかシートは一枚だったんですね。

    For Each WH In Worksheets
        If WH.FilterMode Then
            WH.ShowAllData
        End If
    Next WH
などとあるので、Activeworkbookには複数シートがあると解釈しましたが。
一枚なら杞憂でしたね。
 
そうすると、If WB.Name Like "*_?M*.xlsb" Then
も本当はひとつだけでしょうか?
同時に大きなブックをいくつも開いておくとメモリーが圧迫されて
効率低下の要因になりがちですね。
 
イベントプロシージャは無いんですね。
そうであれば、コード全文を拝見しましたが、最初の質問にたいする回答を
修正する必要はないように思います。
21/06/03 20:50:18で提示したコードを参考に手入れしてもらって様子を見て下さい。

投稿日時: 21/06/07 10:02:14
投稿者: あきこさん

おはようございます。select activesheetの削減に手間取っております。
経過報告はもう少し先になってしまいそうです。
 
 
Simpleさん

そうすると、If WB.Name Like "*_?M*.xlsb" Then 
も本当はひとつだけでしょうか? 
 同時に大きなブックをいくつも開いておくとメモリーが圧迫されて 
効率低下の要因になりがちですね。

 
利用者には「対象ファイルとVBAファイル以外は閉じておいてね」と伝えているのですが、
利用者が数百人に及ぶので保険的に上記のコードを付けています。
対象のファイル名は「(何かの名前)_AM or (何かの名前)_PM」です。

トピックに返信