Method 'SaveAs' of object '_Workbook' failed

[Cinema]

Hi, my Code gives an error for the variable str_FileName in the line I have marked with "ERROR". If I replace this variable with a hard coded string like "String" then the code runs error-free.



Public Sub fkt_Copy()

Dim str_Path_Dest As String
Dim str_FileName As String
Dim str_DestPathName As String
Dim fnPos As Integer
Dim foFS As FileSystemObject
Dim bFileExists, bFileOpen As Boolean

Dim xApp As Excel.Application
Dim xWbk As Workbook
Dim ws As Worksheet
Dim fldr As FileDialog
Dim sItem As String


bFileExists = False
bFileOpen = False


On Error GoTo Err






Dim objShell
Dim strFileName As String
Dim strFilePath As String
Dim objFile As Object

Set objShell = CreateObject("Shell.Application")
Set objFile = objShell.BrowseForFolder(0, "Choose a folder:", &H1, 17)
If objFile Is Nothing Then Exit Sub


str_Path_Dest = objFile.Self.Path

Application.DisplayAlerts = False



str_FileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)


str_DestPathName = str_Path_Dest & "\" & str_FileName & "_output" & ".xlsm"

'Prüfen, ob Workbook offen ist
If Dir(str_DestPathName) <> "" Then
bFileExists = True
If Not IsFileOpen(str_DestPathName) Then
bFileOpen = False
End If
End If

If Not bFileOpen Or Not bFileExists Then
'kopieren falls Clone nicht offen ist oder noch nicht existiert
Set foFS = New Scripting.FileSystemObject
If Left(ThisWorkbook.FullName, 3) Like "*:\" Then
Call foFS.CopyFile(ThisWorkbook.FullName, str_DestPathName, True)
Else
ActiveWorkbook.SaveCopyAs Filename:=str_DestPathName
End If





Set xApp = New Excel.Application
xApp.DisplayAlerts = False
xApp.EnableEvents = False


Set xWbk = xApp.Workbooks.Open(str_DestPathName, ReadOnly:=True)




For Each ws In xWbk.Worksheets
ws.Unprotect
If ws.FilterMode Then
ws.ShowAllData
End If

ws.UsedRange.Copy
ws.UsedRange.PasteSpecial xlPasteValues
Next ws




'Speichern des Clones als xlsx-File und schließen des Workbooks

xWbk.SaveAs str_Path_Dest & "\" & str_FileName & "_output", xlOpenXMLWorkbook <------- ERROR
xWbk.Protect

xWbk.Close


xApp.EnableEvents = True
xApp.DisplayAlerts = True
xApp.Quit

'löschen der als xlsm kopierten Clone-Datei
Kill str_DestPathName
MsgBox "Kopie gespeichert"
Else
MsgBox "Datei kann nicht kopiert werden. Zieldatei geöffnet"
End If
Exit Sub
Err:
MsgBox "Fehler bei Datei kopieren. " & Err.Description

'schließen des Workbooks bei Fehlern
If Not (xWbk Is Nothing) Then
xWbk.Close False
End If


If Not (xApp Is Nothing) Then
xApp.EnableEvents = True
xApp.DisplayAlerts = True
xApp.Quit
End If

Exit Sub



Application.DisplayAlerts = True



End Sub

[大灰狼1976]

@Cinema

xWbk.SaveAs str_Path_Dest & "\" & str_FileName & "_output", xlOpenXMLWorkbook <------- ERROR

When I commented out the <------- ERROR, it worked here without any problem.


--Okami

[大灰狼1976]

@Cinema
You can add this code to try it out and see what msgbox shows.

MsgBox str_Path_Dest & "\" & str_FileName & "_output" '< -------Add
xWbk.SaveAs str_Path_Dest & "\" & str_FileName & "_output", xlOpenXMLWorkbook '< -------Error

I guess str_Path_Dest did not get the correct value because of "on error goto err" line.