エクセルVBAでブックを開くと処理が終わってしまう

質問

VBA初心者なのですが、VBAでエクセルブックを開くとVBAの処理が終わってしまいます。理由がわからないのでアドバイスをお願いします。なお、止まってしまう箇所にコメントを入れプログラムを下記しました。また、4000字以上質問できないためプログラムの途中までしか書かれていません。そのため、余分な宣言が多数ありますが無視してください。よろしくお願いいたします。
Option Base 1
Sub 健康診断の郵送()
Dim kyoNum() As String
Dim b_name As String
Dim a_name() As Variant
Dim b_address As String
Dim a_address() As Variant
Dim mailNum() As Variant
Dim place() As String
Dim banchi() As String
Dim ken() As String
Dim Adr As String
Dim AdrLen As Integer
Dim i, j, k, cnt, l, m As Integer
Dim ChrCode As Integer
Dim cell As Range
Dim Book1 As String
Dim wb As Workbook
Dim Book1_Path As String
Dim flag As Boolean
'セルのクリア
ThisWorkbook.ActiveSheet.Cells.ClearComments
'セルのプロパティを設定をする
With ThisWorkbook.ActiveSheet.Columns("A:B")
.ShrinkToFit = True
.NumberFormatLocal = "@"
.ColumnWidth = 45
End With

'カレントディレクトリのチェンジ(Windows2000以降)
CreateObject("WScript.Shell").CurrentDirectory = ThisWorkbook.Path
'簡易名称Book1にする
Book1 = "Book1.xlsx"
'パスを取得する
Book1_Path = ThisWorkbook.Path & "\" & Book1
If Dir(Book1_Path) = "" Then
MsgBox "Book1.xlsxファイルが存在しません。", vbExclamation
End If
'同名ブックのチェック
For Each wb In Workbooks
If wb.Name = Book1 Then
MsgBox "健康診断の郵送.xlsmはBook1を開こうとしています" _
& vbCrLf & "Book1を閉じて再実行してください", vbExclamation
Exit Sub
End If
Next wb
Application.ScreenUpdating = False
'画面の更新を止める
Workbooks.Open Book1_Path '＊＊＊＊＊←ここで処理が終わってしまう＊＊＊＊＊
'ブック名を指定して非表示
Application.Windows("Book1.xlsx").Visible = False
'後方検索でBook1.xlsxの入力済みセルの行数と列数を取得
With Workbooks("Book1.xlsx").ActiveSheet.UsedRange
Book1_MaxRow = .Find("*", , xlValues, , xlByRows, xlPrevious).Row - 2 'データ入力済み行数取得
End With
Application.ScreenUpdating = True
Workbooks("Book1.xlsx").Activate
j = 1
ReDim kyoNum(Book1_MaxRow)
ReDim a_name(Book1_MaxRow)
ReDim a_address(Book1_MaxRow)
ReDim mailNum(Book1_MaxRow)
ReDim ken(Book1_MaxRow)
ReDim place(Book1_MaxRow)
ReDim banchi(Book1_MaxRow)

回答No.1

end-u

>なお、止まってしまう箇所...
ここで、エラーメッセージが出て止まってしまうという意味ですか。
何というエラーメッセージでしょう？
実行時エラー1004なら、存在しないBookを開こうとしていませんか？

MsgBox "Book1.xlsxファイルが存在しません。"
の表示後に Exit Sub でマクロ終了処理をしていませんから
Bookが存在しない場合でもマクロ継続してしまうような記述になっています。
確認してください。

また、目的のSheetが必ずActiveになっている保障があるなら
ActiveSheet指定で良いかもしれませんが、再考の余地ありです。
それにCurrentDirectory変更の必要性もハテナです。
Book1_MaxRow を得るところまでをまとめてみると以下のような感じかと。

Sub try()
　　Dim wb　　　　　 As Workbook
　　Dim r　　　　　　As Range
　　Dim Book1　　　　As String
　　Dim Book1_Path　 As String
　　Dim Book1_MaxRow As Long

　　With ThisWorkbook.ActiveSheet
　　　　.UsedRange.ClearContents
　　　　With .Columns("A:B")
　　　　　　.ShrinkToFit = True
　　　　　　.NumberFormatLocal = "@"
　　　　　　.ColumnWidth = 45
　　　　End With
　　End With

　　Book1 = "Book1.xlsx"
　　Book1_Path = ThisWorkbook.Path & "\" & Book1
　　If Dir(Book1_Path) = "" Then
　　　　MsgBox "Book1.xlsxファイルが存在しません。", vbExclamation
　　　　Exit Sub
　　End If
　　For Each wb In Workbooks
　　　　If wb.Name = Book1 Then
　　　　　　MsgBox "健康診断の郵送.xlsmはBook1を開こうとしています" & vbCrLf _
　　　　　　　　 & "Book1を閉じて再実行してください", vbExclamation
　　　　　　Set wb = Nothing
　　　　　　Exit Sub
　　　　End If
　　Next wb

　　Application.ScreenUpdating = False
　　Set wb = Workbooks.Open(Book1_Path)
　　wb.Windows(1).Visible = False
　　'Book1_MaxRow = wb.ActiveSheet.UsedRange.Find("*", , xlValues, , xlByRows, xlPrevious).Row - 2
　　Set r = wb.ActiveSheet.UsedRange.Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
　　If r Is Nothing Then
　　　　MsgBox "ActiveSheetのデータ要確認"
　　　　wb.Windows(1).Visible = True
　　　　wb.Activate
　　Else
　　　　Book1_MaxRow = r.Row - 2
　　End If

　　Application.ScreenUpdating = True
　　Set r = Nothing
　　Set wb = Nothing
End Sub