VBA 如何实现批量以表格内容重命名另存

问题遇到的现象和发生背景

无法解决

问题相关代码，请勿粘贴截图

Private Sub CommandButton1_Click()

Dim myPath$, myFile$, am$

Application.DisplayAlerts = False

Application.ScreenUpdating = False

myPath = ThisWorkbook.Path & "\"

myFile = Dir(myPath & "*.xls")

Do While myFile <> ""

If myFile <> ThisWorkbook.Name Then

am = Range("B2").Value & ".xls"
ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & am, FileFormat:=xlOpenXMLWorkbook

Workbooks(myFile).Close True

End If

myFile = Dir

Loop

Application.DisplayAlerts = ture

Application.DisplayAlerts = True

End Sub

运行结果及报错内容

只对文件夹重命名

我的解答思路和尝试过的方法

saveas函数

我想要达到的结果

能自动以表格内容
批量另存改名