| 
    
     |  | ExecuteExcel4Macroは、止めました。 難しすぎるんじゃないかと思います。
 シート名を統一してますか?
 そこまでのエラーチェック等は入れていません。
 これでもエラーになると思いますが...。
 
 Sub ボタン1_Click()
 Dim FldName As String, FalName As String, OPWBk As Workbook
 Dim ReNameSt As String
 Application.ScreenUpdating = False
 FldName = "C:\work\台帳\"
 FalName = Dir(FldName)
 Do Until FalName = ""
 If Right(FalName, 3) = "xls" Or Right(FalName, 3) = "XLS" Then
 Cnt = Cnt + 1
 Set OPWBk = Workbooks.Open(FldName & FalName)
 ReNameSt = OPWBk.Sheets("農道台帳(調書)").Range("N4").Value
 OPWBk.Close (False)
 DoEvents
 Name FldName & FalName As FldName & Format(ReNameSt, "000") & ".xls"
 FalName = Dir()
 End If
 Loop
 If Cnt = 0 Then
 MsgBox "対象ファイルがありません"
 End If
 Application.ScreenUpdating = True
 Set OPWBk = Nothing
 End Sub
 
 |  |