【VBA】マクロ動作中にシートを移動して見えるようにしたい

Question

前提

VBAで任意の日付に入社、異動または退職した社員リストをＣSV形式で出力するマクロを作っています。同じブック内で、シートは以下の3枚です。menuは下記のマクロを登録したボタンを配置するシートです。

1. 異動DB
2. 異動者リスト
3. menu

該当のソースコード

CSVに出力するSubは別のモジュール内にありますが、実現したいことに直接関係ない為、ここでは省略します。（※回答に必要であれば追記します。）

Sub idou()
'異動者リストを作成する

    Dim d As Date
    Dim dval As String
    Dim flag1 As Boolean
    Dim flag2 As Boolean
    Dim i As Long
    Dim cnt As Long
    Dim LastRow As Long
    Dim rg As String
    Dim sec As String
    
    Dim strDateFormat As String
    Dim wS1 As Worksheet
    Dim wS2 As Worksheet
    
    Dim rc As VbMsgBoxResult
    
    'ワークシートを変数で宣言する
    Set wS1 = Worksheets("異動DB")
    Set wS2 = Worksheets("異動者リスト")

    flag1 = False
    flag2 = False
    strDateFormat = wS1.Range("B2").NumberFormatLocal

    '任意の日の異動者を抽出する
    Application.ScreenUpdating = False
        
    '区分を選ぶ
    Do While flag1 = False
        dval = InputBox("数値を入力してください(1:入社、2:異動、3:退職)(※半角数字)")
        If StrPtr(dval) = 0 Then
            'キャンセル又は右上の×をクリックした場合
            Exit Sub
        ElseIf dval = "" Then
            'なにも入力しないでOKをクリックした場合
            MsgBox ("何も入力されていません")
            
        ElseIf dval = "1" Or dval = "2" Or dval = "3" Then
            '入力値が正しい場合
            sec = dval
            flag1 = True
        Else
            '入力値が正しくない場合
            MsgBox ("入力し直してください")
        End If
    Loop
    
    '年月日を入力する
    Do While flag2 = False
        dval = InputBox("基準日を入力してください(記入例：1900/1/1)")
        If StrPtr(dval) = 0 Then
            'キャンセル又は右上の×をクリックした場合
            Exit Sub
        ElseIf dval = "" Then
            'なにも入力しないでOKをクリックした場合
            MsgBox ("何も入力されていません")
            
        ElseIf IsDate(dval) = False Then
            '入力日付が正しくない場合
            MsgBox ("あり得ない日付です")
            
        Else
            '入力日付が正しい場合
            '（必要があれば入力日付のチェックを行い、エラーなら再入力する）
            d = CDate(dval)
            flag2 = True
        End If
    Loop

    '異動者リストで3行目以降をクリアする
    wS2.Rows("3:" & Rows.Count).ClearContents
        
    'オートフィルタで区分データを抽出する
    '（抽出する区分は1:入社、2:異動、3:退職）
    wS1.Range("A1").AutoFilter Field:=1, Criteria1:=sec
        
    'オートフィルタで入力した日付を抽出する
    wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat)
    
    'オートフィルタ結果の行数をカウントする
    rg = "D1:D" & wS1.Range("D1").CurrentRegion.Rows.Count
    cnt = WorksheetFunction.Subtotal(103, wS1.Range(rg))
    
    '1行のみの場合（見出し行のみ）終了する
    If cnt = 1 Then
        MsgBox ("該当する社員が存在しません")
        
        'オートフィルタを解除
        wS1.Range("A1").AutoFilter
        wS1.Range("B1").AutoFilter
        
        Exit Sub
    End If
            
    '抽出した社員番号をコピーして貼り付ける
    LastRow = wS1.Cells(Rows.Count, "D").End(xlUp).Row
    wS1.Range("D1").CurrentRegion.Range("D1").Offset(1, 0).Resize(LastRow - 1, 1).Copy wS2.Range("A3")
    
    '異動者リストにコピー貼り付け
    Call Copy
    
    '異動者リストをCSVで出力
    rc = MsgBox("該当社員情報をCSVで出力しますか？", vbYesNo + vbQuestion)
        If rc = vbYes Then
           '「はい」をクリックした場合
           Call Module6.CSV出力
           
        Else
           '「いいえ」をクリックした場合
           Exit Sub
           
        End If
      
    Application.ScreenUpdating = True
     
End Sub

実現したいこと

このマクロの動作中、画面は【menu】のままです。

• (103行目)【異動者リスト】に抽出結果を貼り付けた時
• (106行目)メッセージボックスを表示させる時

この間のタイミングで、【異動者リスト】に移動させたいです。
抽出結果が正しいかユーザーに確認してもらうのが目的です。

試したこと・発生している問題

シンプルに103行目と106行目の間にActivateを入れればいいだろう、と思い、入れてみたのですが、【異動DB】が真っ白なままで移動されませんでした。メッセージボックス自体は問題なく動作しました。

wS2.Activate

Application.ScreenUpdatingの内部だと動作しないのかな、とも思いましたが原因がよく分からないです。原因が分かる方、解決策をご教示いただければ幸いです。よろしくお願いいたします。

補足情報（FW/ツールのバージョンなど）

PC：Windows11
ソフト：Microsoft365 Excel
参考URL:エクセルの学校

Comments

[pig_vba]

ScreenUpdating = Falseしてるからですね。

ScreenUpdating = True
DoEvents
ScreenUpdating = False

を試してみてください

[koburon]

>pig_vba様
コメントありがとうございます。
間のDoEventsの位置ですが、
ScreenUpdating = True
の直下でよろしいでしょうか。

[pig_vba]

直下です。activateのかわりに3つセットで入れる感じです

内容としては
一旦再描画オンにしてDoEventsだけして即オフにするって感じです。弊環境ではこれで再描画できてるので多分大丈夫です

[koburon]

>pig_vba様
コメントありがとうございます。
103行目と106行目の間に3文をこの通りの並びで入れて実行しましたが、シートが移動されませんでした。
ただ入れるだけではダメで、29行目のScreenUpdatingのように他のコードも修正が必要なのでしょうか。

[pig_vba]

あ、すみません。単純に最新の状態を確認したいだけ（アクティブシートは変化していない）であると解釈してました。
それであればDoEventsの直前にSheet.activateも一緒に入れてください
再描画オン→シート移動→DoEvents→再描画オフの順です

[koburon]

>pig_vba様
コメントありがとうございます。
ご指摘の通り4つの文で入力して実行したところ、要望通り、シートを移動させることができました。
ベストアンサーとさせていただきたいのですが、回答ではないので、自己解決に記入して締め切らせていただきます。
ありがとうございました。

Answer 1

いただいたコメントに倣って、106行目の前に以下のコードを追加すると、要望通り、シートを移動させることができました。

    '画面更新を再開して異動者リストに移動
    Application.ScreenUpdating = True
    wS2.Activate
    DoEvents
    Application.ScreenUpdating = False