Method saveas of object workbook failed 1004 ошибка vba - Исправление ошибок и поиск оптимальных решений проблем

Hello,

I have code designed to create an archive of my main sheet (as a .xlsx) by copying the sheet > saving the copied sheet in a new workbook > doing things to the sheet within the new workbook > saving and closing new workbook then continuing the rest of my code.

Everything works as coded except when the user selects (or keeps selected) the same file location, in the SaveAs dialog, that the original file (with the running VBA) is in. It returns a «Method ‘SaveAs’ of object ‘_Workbook’ failed» error.

I created an «If» check to see if the selected file location from the SaveAs dialog is the same as the file location of the original and was able to create an error handler (avoid the error), but not an error solution. I want to default to the same file location as the original, and regardless I want the user to be able to save into the same file location, especially since that is a very typical thing to do.

Line (59) with error 1004:

ActiveWorkbook.SaveAs fileName:=PathAndFile_Name, FileFormat:=xlOpenXMLWorkbook

ShiftYear (what code is in) and PleaseWait are userforms, and «Troop to Task — Tracker» is the sheet I’m copying.

Code with error:

'<PREVIOUS CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'''Declare variables:
'General:
Dim NewGenYear As Integer, LastGenYear As Integer, year_create_counter As Integer
NewGenYear = 0: LastGenYear = 0: year_create_counter = 0
'Personnel:
Dim cell_person As Range, cell_num As Range
Dim cell_num_default As Range
'Archive:
Dim Sheet_Archive As Worksheet, ShVal As Integer
Dim ObFD As FileDialog
Dim File_Name As String
Dim PathAndFile_Name As String
Dim Shape_Clr As Shape
Dim cell_color_convert As Range

'<A WHOLE BUNCH OF OTHER CHECKS AND CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'Set then launch SaveAs dialog:
If ShiftYear.CheckBox5.Value = True Then 'Archive <=5 year(s) data externally - Checked:
    For Each Sheet_Archive In ThisWorkbook.Sheets
    Select Case Sheet_Archive.CodeName
    Case Is = "Sheet4", "Sheet5", "Sheet6", "Sheet7"
    ShVal = Sheet_Archive.Name
    If Sheet_Archive.Range("A2").Value <> "N/A" And ShVal <> ShiftYear.Shift_3.Value Then
    File_Name = "Archive " & Sheet_Archive.Name & "_" & ThisWorkbook.Name 'Set default (suggested) File Name
    Set ObFD = Application.FileDialog(msoFileDialogSaveAs)
    With ObFD
        .Title = "Archive Year(s) - Personnel Tracker"
        .ButtonName = "A&rchive"
        .InitialFileName = ThisWorkbook.Path & "" & File_Name 'Default file location and File Name
        .FilterIndex = 1 'File Type (.xlsx)
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .Show
        If .SelectedItems.count = 0 Then
        MsgBox "Generation and archiving canceled. No year(s) were created, shifted, or overwritten. To continue generating without archiving, uncheck the ""Archive <=5 year(s) calendar/personnel data externally before overwriting"" box then click ""Generate"" again." _
        , vbExclamation, "Year Shift & Creation - Personnel Tracker"
        '<MY CODE THAT TURNS OFF MACRO ENHANCEMENT>
        Exit Sub
        Else
        PathAndFile_Name = .SelectedItems(1)
        End If
    End With
    Application.DisplayAlerts = False
    
'Load year to be archived:
    Worksheets("Formula & Code Data").Range("I7").Value = Sheet_Archive.Name
    Worksheets("Formula & Code Data").Range("I13").Value = "No"
    Call Load_Year.Load_Year

'Copy Troop to Task - Tracker sheet into new workbook and format:
    PleaseWait.Label2.Caption = "Creating " & Sheet_Archive.Name & " archive file ..."
    DoEvents
    File_Name = Right(PathAndFile_Name, Len(PathAndFile_Name) - InStrRev(PathAndFile_Name, "")) 'Update File Name to user's input
    ThisWorkbook.Sheets("Troop to Task - Tracker").Copy

    ActiveWorkbook.SaveAs fileName:=PathAndFile_Name, FileFormat:=xlOpenXMLWorkbook 'New workbook save and activate

    '<ALL MY CODE THAT CHANGES THE NEW WORKBOOK>

    Excel.Workbooks(File_Name).Activate
    Excel.Workbooks(File_Name).Close savechanges:=True 'New workbook save and close
    Application.DisplayAlerts = True
    End If
    End Select
    If (Sheet_Archive.CodeName = "Sheet4" Or Sheet_Archive.CodeName = "Sheet5" _
    Or Sheet_Archive.CodeName = "Sheet6" Or Sheet_Archive.CodeName = "Sheet7") _
    And ShVal <> ShiftYear.Shift_3.Value Then
    PleaseWait.Label2.Caption = "" & Sheet_Archive.Name & " archive file complete"
    DoEvents
    Else: PleaseWait.Label2.Caption = "Initailizing archive ..."
    DoEvents: End If
    Next Sheet_Archive
ElseIf ShiftYear.CheckBox5.Value = False Then 'Archive <=5 year(s) data externally - Unchecked:
    'Do Nothing
End If 'Archive <=5 year(s) data externally - END

'<CONTINUING CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

Code with error handler:

'<PREVIOUS CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'''Declare variables:
'General:
Dim NewGenYear As Integer, LastGenYear As Integer, year_create_counter As Integer
NewGenYear = 0: LastGenYear = 0: year_create_counter = 0
'Personnel:
Dim cell_person As Range, cell_num As Range
Dim cell_num_default As Range
'Archive:
Dim Sheet_Archive As Worksheet, ShVal As Integer
Dim ObFD As FileDialog
Dim File_Name As String
Dim PathAndFile_Name As String
Dim Shape_Clr As Shape
Dim cell_color_convert As Range

'<A WHOLE BUNCH OF OTHER CHECKS AND CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'Set then launch SaveAs dialog:
If ShiftYear.CheckBox5.Value = True Then 'Archive <=5 year(s) data externally - Checked:
    For Each Sheet_Archive In ThisWorkbook.Sheets
    Select Case Sheet_Archive.CodeName
    Case Is = "Sheet4", "Sheet5", "Sheet6", "Sheet7"
Archive_Error:
    ShVal = Sheet_Archive.Name
    If Sheet_Archive.Range("A2").Value <> "N/A" And ShVal <> ShiftYear.Shift_3.Value Then
    File_Name = "Archive " & Sheet_Archive.Name & "_" & ThisWorkbook.Name 'Set default (suggested) File Name
    Set ObFD = Application.FileDialog(msoFileDialogSaveAs)
    With ObFD
        .Title = "Archive Year(s) - Personnel Tracker"
        .ButtonName = "A&rchive"
        .InitialFileName = ThisWorkbook.Path & "" & File_Name 'Default file location and File Name
        .FilterIndex = 1 'File Type (.xlsx)
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .Show
        If .SelectedItems.count = 0 Then
        MsgBox "Generation and archiving canceled. No year(s) were created, shifted, or overwritten. To continue generating without archiving, uncheck the ""Archive <=5 year(s) calendar/personnel data externally before overwriting"" box then click ""Generate"" again." _
        , vbExclamation, "Year Shift & Creation - Personnel Tracker"
        '<MY CODE THAT TURNS OFF MACRO ENHANCEMENT>
        Exit Sub
        Else
        PathAndFile_Name = .SelectedItems(1)
        End If
    End With
    Application.DisplayAlerts = False
    
'Load year to be archived:
    Worksheets("Formula & Code Data").Range("I7").Value = Sheet_Archive.Name
    Worksheets("Formula & Code Data").Range("I13").Value = "No"
    Call Load_Year.Load_Year

'Copy Troop to Task - Tracker sheet into new workbook and format:
    PleaseWait.Label2.Caption = "Creating " & Sheet_Archive.Name & " archive file ..."
    DoEvents
    File_Name = Right(PathAndFile_Name, Len(PathAndFile_Name) - InStrRev(PathAndFile_Name, "")) 'Update File Name to user's input
    ThisWorkbook.Sheets("Troop to Task - Tracker").Copy
    
    If PathAndFile_Name = ThisWorkbook.Path & "" & File_Name Then 'Error handler
Archive_Error_Actual:
    MsgBox "You cannot save into the same location as this Tracker, in this version. Please select a different file location." _
    , vbExclamation, "Year Shift & Creation - Personnel Tracker"
    'UPDATE MESSAGE AND FIGURE OUT WAY TO FIX RUNTIME ERROR WHEN SAVING TO SAME LOCATION AS THE TRACKER!!!
    ActiveWorkbook.Close savechanges:=False
    GoTo Archive_Error
    End If
    On Error GoTo Archive_Error_Actual
    ActiveWorkbook.SaveAs fileName:=PathAndFile_Name, FileFormat:=xlOpenXMLWorkbook 'New workbook save and activate

    '<ALL MY CODE THAT CHANGES THE NEW WORKBOOK>

    Excel.Workbooks(File_Name).Activate
    Excel.Workbooks(File_Name).Close savechanges:=True 'New workbook save and close
    Application.DisplayAlerts = True
    End If
    End Select
    If (Sheet_Archive.CodeName = "Sheet4" Or Sheet_Archive.CodeName = "Sheet5" _
    Or Sheet_Archive.CodeName = "Sheet6" Or Sheet_Archive.CodeName = "Sheet7") _
    And ShVal <> ShiftYear.Shift_3.Value Then
    PleaseWait.Label2.Caption = "" & Sheet_Archive.Name & " archive file complete"
    DoEvents
    Else: PleaseWait.Label2.Caption = "Initailizing archive ..."
    DoEvents: End If
    Next Sheet_Archive
ElseIf ShiftYear.CheckBox5.Value = False Then 'Archive <=5 year(s) data externally - Unchecked:
    'Do Nothing
End If 'Archive <=5 year(s) data externally - END

'<CONTINUING CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

Any solution to this is much appreciated!

Источник

xseed

Пользователь

Сообщений: 15
Регистрация: 05.08.2016

05.08.2016 17:50:04

Добрый день! Есть файл xls2txt с макросом, экспортирующий другой файл xls в текст:

Код

Sub Макрос1()
'
' Макрос1 Макрос
    Workbooks.Open Filename:="C:nnCronthebat!1.xls"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:="C:nncronthebat!1.txt", FileFormat:= _
        xlUnicodeText, CreateBackup:=False
    ActiveWorkbook.Save
    Application.DisplayAlerts = True
    ActiveWindow.Close False
    Windows("xls2txt.xls").Activate
    Application.Quit
End Sub

при попытке выполнить который выдается это сообщение: Run-time error ‘1004’: Method ‘Saveas’ of object ‘_workbook’ failed

Debug переходит на строку

Код
ActiveWorkbook.SaveAs Filename:="C:nncronthebat!1.txt", FileFormat:= _ xlUnicodeText, CreateBackup:=False

Суть проблемы в том, если файл 1.xls не запаролен, он отрабатывает успешно, без ошибок. Но когда я пытаюсь запустить файл, имеющий запароленный макрос, вываливается эта ошибка. При этом, если сохранять вручную, никаких проблем не возникает. Проблемный файл 1.xls прилагаю.

Прикрепленные файлы

1.zip (18.09 КБ)

Изменено: xseed — 05.08.2016 18:07:23

The_Prist

Пользователь

Сообщений: 13997
Регистрация: 15.09.2012

Профессиональная разработка приложений для MS Office

Тут все просто. Вы пытаетесь сохранить файл, который уже открыт под тем же именем самим Excel. Поэтому VBA и генерирует ошибку — файл занят процессом и не может быть перезаписан. Это недопустимо. Сохраняйте либо в другую папку, либо под другими именем.

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы…

xseed

Пользователь

Сообщений: 15
Регистрация: 05.08.2016

05.08.2016 17:59:05

Цитата
The_Prist написал: Вы пытаетесь сохранить файл, который уже открыт под тем же именем

Я открываю файл xls2txt.xls. Выполняю в нем макрос1. Открывается файл 1.xls, сохраняется как 1.txt. Где тут сохранение под тем же именем? Имя то же. но расширение txt. причем, когда я делал запись макроса, excel спрашивал меня. что файл 1.txt уже существует. заменить? Я согласился, нажав Да.

Изменено: xseed — 05.08.2016 17:59:30
(ошибка)

The_Prist

Пользователь

Сообщений: 13997
Регистрация: 15.09.2012

Профессиональная разработка приложений для MS Office

05.08.2016 18:02:04

Да, проглядел расширение. Сказывается, видимо, пятница
Но тем не менее. Файл такой есть и Excel делает запрос на его замену. И незаметно для Вас сначала его удаляет, а потом записывает новый. VBA этого за Вас делать не будет. И ошибка в VBA у Вас явно так же говорит о том, что файл такой уже есть. Поэтому сначала убедитесь, что такого файла нет на диске. Если есть — удаляйте:

Код

If dir("C:nncronthebat!1.txt",16) <> "" then
kill "C:nncronthebat!1.txt" 'удаляем файл, если он есть
end if
ActiveWorkbook.SaveAs Filename:="C:nncronthebat!1.txt", FileFormat:=xlUnicodeText, CreateBackup:=False

P.S. Оформляйте код соответствующим тегом(<…>), а не шрифтом. Так нагляднее будет.

Изменено: The_Prist — 05.08.2016 18:02:36

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы…

xseed

Пользователь

Сообщений: 15
Регистрация: 05.08.2016

The_Prist

, нет, файл 1.txt тут ни причем. Если вы выполните мой макрос с обычным xls файлом, никаких ошибок не возникнет, файл сохранится как txt, даже если он существует. Проблема возникнет, только если выполнить макрос с прикрепленным файлом 1.xls (причем его надо поместить в каталог C:nnCronthebat!)

PS: прикрепил файл с макросом xls2txt.xls

Изменено: xseed — 05.08.2016 18:12:04

The_Prist Пользователь Сообщений: 13997 Регистрация: 15.09.2012 Профессиональная разработка приложений для MS Office	Пароль к проекту какой? Может там еще какое событие срабатывает. Изменено: The_Prist — 05.08.2016 18:17:59 Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы…

xseed Пользователь Сообщений: 15 Регистрация: 05.08.2016	Это не мой файл, пароля не знаю. Может быть, потому, что в 1.xls установлен VBAProject Password, макрос в файле xls2txt не отрабатывает? Тогда экспорт вручную в txt на этом файле 1.xls почему тогда работает? Изменено: xseed — 05.08.2016 18:29:52

xseed

Пользователь

Сообщений: 15
Регистрация: 05.08.2016

А можно тогда, если уж макрос не получается выполнить на запаролленом файле, не выполнять его вообще? То есть, можно ли предварительно перед выполнением макроса проверить файл на защиту и если она установлена — не выполнять макрос? Как это сделать?

Изменено: xseed — 05.08.2016 18:33:47

The_Prist

Пользователь

Сообщений: 13997
Регистрация: 15.09.2012

Профессиональная разработка приложений для MS Office

05.08.2016 18:32:39

Тогда сделайте так:

Код

Sub Макрос1()
'
' Макрос1 Макрос
'

'
    Workbooks.Open Filename:="C:nnCronthebat!1.xls"
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ActiveWorkbook.Sheets(1).Copy
    ActiveWorkbook.SaveAs Filename:="C:nncronthebat!1.txt", FileFormat:= _
        xlUnicodeText, CreateBackup:=False
    ActiveWorkbook.Save
    Application.DisplayAlerts = True
    ActiveWindow.Close False
    Windows("xls2txt.xls").Activate
    Application.Quit
End Sub

больше одного листа все равно не сохраните в txt

Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы…

xseed

Пользователь

Сообщений: 15
Регистрация: 05.08.2016

#10

05.08.2016 18:40:31

Цитата
The_Prist написал: ActiveWorkbook.Sheets(1).Copy

Спасибо!
А как работает эта команда? Просто копирует лист или же копирует книгу? Тогда в чем причина проблемы?

Изменено: xseed — 05.08.2016 18:40:53

The_Prist Пользователь Сообщений: 13997 Регистрация: 15.09.2012 Профессиональная разработка приложений для MS Office	#11 05.08.2016 18:44:31 Эта команда копирует один(в данном случае первый) лист в новую книгу. Книга создается автоматически. В чем проблема? В том, что есть пароль на проект. А файл Вы кодом сохраняете без этого самого проекта. И т.к. там есть пароль на проект VBA — то доступа к проекту извне нет для его модификации. А удаление — та еще модификация. Т.е. по факту Вы не можете сохранить данный файл в любом формате, который не поддерживает хранение VBA проекта. А при копировании листа создается новая книга с одним лишь листом и без всяких проектов и защиты. Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы…

Источник

Hello,

Line (59) with error 1004:

ActiveWorkbook.SaveAs fileName:=PathAndFile_Name, FileFormat:=xlOpenXMLWorkbook

ShiftYear (what code is in) and PleaseWait are userforms, and «Troop to Task — Tracker» is the sheet I’m copying.

Code with error:

'<PREVIOUS CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'''Declare variables:
'General:
Dim NewGenYear As Integer, LastGenYear As Integer, year_create_counter As Integer
NewGenYear = 0: LastGenYear = 0: year_create_counter = 0
'Personnel:
Dim cell_person As Range, cell_num As Range
Dim cell_num_default As Range
'Archive:
Dim Sheet_Archive As Worksheet, ShVal As Integer
Dim ObFD As FileDialog
Dim File_Name As String
Dim PathAndFile_Name As String
Dim Shape_Clr As Shape
Dim cell_color_convert As Range

'<A WHOLE BUNCH OF OTHER CHECKS AND CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'Set then launch SaveAs dialog:
If ShiftYear.CheckBox5.Value = True Then 'Archive <=5 year(s) data externally - Checked:
    For Each Sheet_Archive In ThisWorkbook.Sheets
    Select Case Sheet_Archive.CodeName
    Case Is = "Sheet4", "Sheet5", "Sheet6", "Sheet7"
    ShVal = Sheet_Archive.Name
    If Sheet_Archive.Range("A2").Value <> "N/A" And ShVal <> ShiftYear.Shift_3.Value Then
    File_Name = "Archive " & Sheet_Archive.Name & "_" & ThisWorkbook.Name 'Set default (suggested) File Name
    Set ObFD = Application.FileDialog(msoFileDialogSaveAs)
    With ObFD
        .Title = "Archive Year(s) - Personnel Tracker"
        .ButtonName = "A&rchive"
        .InitialFileName = ThisWorkbook.Path & "" & File_Name 'Default file location and File Name
        .FilterIndex = 1 'File Type (.xlsx)
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .Show
        If .SelectedItems.count = 0 Then
        MsgBox "Generation and archiving canceled. No year(s) were created, shifted, or overwritten. To continue generating without archiving, uncheck the ""Archive <=5 year(s) calendar/personnel data externally before overwriting"" box then click ""Generate"" again." _
        , vbExclamation, "Year Shift & Creation - Personnel Tracker"
        '<MY CODE THAT TURNS OFF MACRO ENHANCEMENT>
        Exit Sub
        Else
        PathAndFile_Name = .SelectedItems(1)
        End If
    End With
    Application.DisplayAlerts = False
    
'Load year to be archived:
    Worksheets("Formula & Code Data").Range("I7").Value = Sheet_Archive.Name
    Worksheets("Formula & Code Data").Range("I13").Value = "No"
    Call Load_Year.Load_Year

'Copy Troop to Task - Tracker sheet into new workbook and format:
    PleaseWait.Label2.Caption = "Creating " & Sheet_Archive.Name & " archive file ..."
    DoEvents
    File_Name = Right(PathAndFile_Name, Len(PathAndFile_Name) - InStrRev(PathAndFile_Name, "")) 'Update File Name to user's input
    ThisWorkbook.Sheets("Troop to Task - Tracker").Copy

    ActiveWorkbook.SaveAs fileName:=PathAndFile_Name, FileFormat:=xlOpenXMLWorkbook 'New workbook save and activate

    '<ALL MY CODE THAT CHANGES THE NEW WORKBOOK>

    Excel.Workbooks(File_Name).Activate
    Excel.Workbooks(File_Name).Close savechanges:=True 'New workbook save and close
    Application.DisplayAlerts = True
    End If
    End Select
    If (Sheet_Archive.CodeName = "Sheet4" Or Sheet_Archive.CodeName = "Sheet5" _
    Or Sheet_Archive.CodeName = "Sheet6" Or Sheet_Archive.CodeName = "Sheet7") _
    And ShVal <> ShiftYear.Shift_3.Value Then
    PleaseWait.Label2.Caption = "" & Sheet_Archive.Name & " archive file complete"
    DoEvents
    Else: PleaseWait.Label2.Caption = "Initailizing archive ..."
    DoEvents: End If
    Next Sheet_Archive
ElseIf ShiftYear.CheckBox5.Value = False Then 'Archive <=5 year(s) data externally - Unchecked:
    'Do Nothing
End If 'Archive <=5 year(s) data externally - END

'<CONTINUING CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

Code with error handler:

'<PREVIOUS CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'''Declare variables:
'General:
Dim NewGenYear As Integer, LastGenYear As Integer, year_create_counter As Integer
NewGenYear = 0: LastGenYear = 0: year_create_counter = 0
'Personnel:
Dim cell_person As Range, cell_num As Range
Dim cell_num_default As Range
'Archive:
Dim Sheet_Archive As Worksheet, ShVal As Integer
Dim ObFD As FileDialog
Dim File_Name As String
Dim PathAndFile_Name As String
Dim Shape_Clr As Shape
Dim cell_color_convert As Range

'<A WHOLE BUNCH OF OTHER CHECKS AND CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'Set then launch SaveAs dialog:
If ShiftYear.CheckBox5.Value = True Then 'Archive <=5 year(s) data externally - Checked:
    For Each Sheet_Archive In ThisWorkbook.Sheets
    Select Case Sheet_Archive.CodeName
    Case Is = "Sheet4", "Sheet5", "Sheet6", "Sheet7"
Archive_Error:
    ShVal = Sheet_Archive.Name
    If Sheet_Archive.Range("A2").Value <> "N/A" And ShVal <> ShiftYear.Shift_3.Value Then
    File_Name = "Archive " & Sheet_Archive.Name & "_" & ThisWorkbook.Name 'Set default (suggested) File Name
    Set ObFD = Application.FileDialog(msoFileDialogSaveAs)
    With ObFD
        .Title = "Archive Year(s) - Personnel Tracker"
        .ButtonName = "A&rchive"
        .InitialFileName = ThisWorkbook.Path & "" & File_Name 'Default file location and File Name
        .FilterIndex = 1 'File Type (.xlsx)
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .Show
        If .SelectedItems.count = 0 Then
        MsgBox "Generation and archiving canceled. No year(s) were created, shifted, or overwritten. To continue generating without archiving, uncheck the ""Archive <=5 year(s) calendar/personnel data externally before overwriting"" box then click ""Generate"" again." _
        , vbExclamation, "Year Shift & Creation - Personnel Tracker"
        '<MY CODE THAT TURNS OFF MACRO ENHANCEMENT>
        Exit Sub
        Else
        PathAndFile_Name = .SelectedItems(1)
        End If
    End With
    Application.DisplayAlerts = False
    
'Load year to be archived:
    Worksheets("Formula & Code Data").Range("I7").Value = Sheet_Archive.Name
    Worksheets("Formula & Code Data").Range("I13").Value = "No"
    Call Load_Year.Load_Year

'Copy Troop to Task - Tracker sheet into new workbook and format:
    PleaseWait.Label2.Caption = "Creating " & Sheet_Archive.Name & " archive file ..."
    DoEvents
    File_Name = Right(PathAndFile_Name, Len(PathAndFile_Name) - InStrRev(PathAndFile_Name, "")) 'Update File Name to user's input
    ThisWorkbook.Sheets("Troop to Task - Tracker").Copy
    
    If PathAndFile_Name = ThisWorkbook.Path & "" & File_Name Then 'Error handler
Archive_Error_Actual:
    MsgBox "You cannot save into the same location as this Tracker, in this version. Please select a different file location." _
    , vbExclamation, "Year Shift & Creation - Personnel Tracker"
    'UPDATE MESSAGE AND FIGURE OUT WAY TO FIX RUNTIME ERROR WHEN SAVING TO SAME LOCATION AS THE TRACKER!!!
    ActiveWorkbook.Close savechanges:=False
    GoTo Archive_Error
    End If
    On Error GoTo Archive_Error_Actual
    ActiveWorkbook.SaveAs fileName:=PathAndFile_Name, FileFormat:=xlOpenXMLWorkbook 'New workbook save and activate

    '<ALL MY CODE THAT CHANGES THE NEW WORKBOOK>

    Excel.Workbooks(File_Name).Activate
    Excel.Workbooks(File_Name).Close savechanges:=True 'New workbook save and close
    Application.DisplayAlerts = True
    End If
    End Select
    If (Sheet_Archive.CodeName = "Sheet4" Or Sheet_Archive.CodeName = "Sheet5" _
    Or Sheet_Archive.CodeName = "Sheet6" Or Sheet_Archive.CodeName = "Sheet7") _
    And ShVal <> ShiftYear.Shift_3.Value Then
    PleaseWait.Label2.Caption = "" & Sheet_Archive.Name & " archive file complete"
    DoEvents
    Else: PleaseWait.Label2.Caption = "Initailizing archive ..."
    DoEvents: End If
    Next Sheet_Archive
ElseIf ShiftYear.CheckBox5.Value = False Then 'Archive <=5 year(s) data externally - Unchecked:
    'Do Nothing
End If 'Archive <=5 year(s) data externally - END

'<CONTINUING CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

Any solution to this is much appreciated!

Источник

Hello,

Line (59) with error 1004:

ActiveWorkbook.SaveAs fileName:=PathAndFile_Name, FileFormat:=xlOpenXMLWorkbook

ShiftYear (what code is in) and PleaseWait are userforms, and «Troop to Task — Tracker» is the sheet I’m copying.

Code with error:

'<PREVIOUS CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'''Declare variables:
'General:
Dim NewGenYear As Integer, LastGenYear As Integer, year_create_counter As Integer
NewGenYear = 0: LastGenYear = 0: year_create_counter = 0
'Personnel:
Dim cell_person As Range, cell_num As Range
Dim cell_num_default As Range
'Archive:
Dim Sheet_Archive As Worksheet, ShVal As Integer
Dim ObFD As FileDialog
Dim File_Name As String
Dim PathAndFile_Name As String
Dim Shape_Clr As Shape
Dim cell_color_convert As Range

'<A WHOLE BUNCH OF OTHER CHECKS AND CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'Set then launch SaveAs dialog:
If ShiftYear.CheckBox5.Value = True Then 'Archive <=5 year(s) data externally - Checked:
    For Each Sheet_Archive In ThisWorkbook.Sheets
    Select Case Sheet_Archive.CodeName
    Case Is = "Sheet4", "Sheet5", "Sheet6", "Sheet7"
    ShVal = Sheet_Archive.Name
    If Sheet_Archive.Range("A2").Value <> "N/A" And ShVal <> ShiftYear.Shift_3.Value Then
    File_Name = "Archive " & Sheet_Archive.Name & "_" & ThisWorkbook.Name 'Set default (suggested) File Name
    Set ObFD = Application.FileDialog(msoFileDialogSaveAs)
    With ObFD
        .Title = "Archive Year(s) - Personnel Tracker"
        .ButtonName = "A&rchive"
        .InitialFileName = ThisWorkbook.Path & "" & File_Name 'Default file location and File Name
        .FilterIndex = 1 'File Type (.xlsx)
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .Show
        If .SelectedItems.count = 0 Then
        MsgBox "Generation and archiving canceled. No year(s) were created, shifted, or overwritten. To continue generating without archiving, uncheck the ""Archive <=5 year(s) calendar/personnel data externally before overwriting"" box then click ""Generate"" again." _
        , vbExclamation, "Year Shift & Creation - Personnel Tracker"
        '<MY CODE THAT TURNS OFF MACRO ENHANCEMENT>
        Exit Sub
        Else
        PathAndFile_Name = .SelectedItems(1)
        End If
    End With
    Application.DisplayAlerts = False
    
'Load year to be archived:
    Worksheets("Formula & Code Data").Range("I7").Value = Sheet_Archive.Name
    Worksheets("Formula & Code Data").Range("I13").Value = "No"
    Call Load_Year.Load_Year

'Copy Troop to Task - Tracker sheet into new workbook and format:
    PleaseWait.Label2.Caption = "Creating " & Sheet_Archive.Name & " archive file ..."
    DoEvents
    File_Name = Right(PathAndFile_Name, Len(PathAndFile_Name) - InStrRev(PathAndFile_Name, "")) 'Update File Name to user's input
    ThisWorkbook.Sheets("Troop to Task - Tracker").Copy

    ActiveWorkbook.SaveAs fileName:=PathAndFile_Name, FileFormat:=xlOpenXMLWorkbook 'New workbook save and activate

    '<ALL MY CODE THAT CHANGES THE NEW WORKBOOK>

    Excel.Workbooks(File_Name).Activate
    Excel.Workbooks(File_Name).Close savechanges:=True 'New workbook save and close
    Application.DisplayAlerts = True
    End If
    End Select
    If (Sheet_Archive.CodeName = "Sheet4" Or Sheet_Archive.CodeName = "Sheet5" _
    Or Sheet_Archive.CodeName = "Sheet6" Or Sheet_Archive.CodeName = "Sheet7") _
    And ShVal <> ShiftYear.Shift_3.Value Then
    PleaseWait.Label2.Caption = "" & Sheet_Archive.Name & " archive file complete"
    DoEvents
    Else: PleaseWait.Label2.Caption = "Initailizing archive ..."
    DoEvents: End If
    Next Sheet_Archive
ElseIf ShiftYear.CheckBox5.Value = False Then 'Archive <=5 year(s) data externally - Unchecked:
    'Do Nothing
End If 'Archive <=5 year(s) data externally - END

'<CONTINUING CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

Code with error handler:

'<PREVIOUS CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'''Declare variables:
'General:
Dim NewGenYear As Integer, LastGenYear As Integer, year_create_counter As Integer
NewGenYear = 0: LastGenYear = 0: year_create_counter = 0
'Personnel:
Dim cell_person As Range, cell_num As Range
Dim cell_num_default As Range
'Archive:
Dim Sheet_Archive As Worksheet, ShVal As Integer
Dim ObFD As FileDialog
Dim File_Name As String
Dim PathAndFile_Name As String
Dim Shape_Clr As Shape
Dim cell_color_convert As Range

'<A WHOLE BUNCH OF OTHER CHECKS AND CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

'Set then launch SaveAs dialog:
If ShiftYear.CheckBox5.Value = True Then 'Archive <=5 year(s) data externally - Checked:
    For Each Sheet_Archive In ThisWorkbook.Sheets
    Select Case Sheet_Archive.CodeName
    Case Is = "Sheet4", "Sheet5", "Sheet6", "Sheet7"
Archive_Error:
    ShVal = Sheet_Archive.Name
    If Sheet_Archive.Range("A2").Value <> "N/A" And ShVal <> ShiftYear.Shift_3.Value Then
    File_Name = "Archive " & Sheet_Archive.Name & "_" & ThisWorkbook.Name 'Set default (suggested) File Name
    Set ObFD = Application.FileDialog(msoFileDialogSaveAs)
    With ObFD
        .Title = "Archive Year(s) - Personnel Tracker"
        .ButtonName = "A&rchive"
        .InitialFileName = ThisWorkbook.Path & "" & File_Name 'Default file location and File Name
        .FilterIndex = 1 'File Type (.xlsx)
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .Show
        If .SelectedItems.count = 0 Then
        MsgBox "Generation and archiving canceled. No year(s) were created, shifted, or overwritten. To continue generating without archiving, uncheck the ""Archive <=5 year(s) calendar/personnel data externally before overwriting"" box then click ""Generate"" again." _
        , vbExclamation, "Year Shift & Creation - Personnel Tracker"
        '<MY CODE THAT TURNS OFF MACRO ENHANCEMENT>
        Exit Sub
        Else
        PathAndFile_Name = .SelectedItems(1)
        End If
    End With
    Application.DisplayAlerts = False
    
'Load year to be archived:
    Worksheets("Formula & Code Data").Range("I7").Value = Sheet_Archive.Name
    Worksheets("Formula & Code Data").Range("I13").Value = "No"
    Call Load_Year.Load_Year

'Copy Troop to Task - Tracker sheet into new workbook and format:
    PleaseWait.Label2.Caption = "Creating " & Sheet_Archive.Name & " archive file ..."
    DoEvents
    File_Name = Right(PathAndFile_Name, Len(PathAndFile_Name) - InStrRev(PathAndFile_Name, "")) 'Update File Name to user's input
    ThisWorkbook.Sheets("Troop to Task - Tracker").Copy
    
    If PathAndFile_Name = ThisWorkbook.Path & "" & File_Name Then 'Error handler
Archive_Error_Actual:
    MsgBox "You cannot save into the same location as this Tracker, in this version. Please select a different file location." _
    , vbExclamation, "Year Shift & Creation - Personnel Tracker"
    'UPDATE MESSAGE AND FIGURE OUT WAY TO FIX RUNTIME ERROR WHEN SAVING TO SAME LOCATION AS THE TRACKER!!!
    ActiveWorkbook.Close savechanges:=False
    GoTo Archive_Error
    End If
    On Error GoTo Archive_Error_Actual
    ActiveWorkbook.SaveAs fileName:=PathAndFile_Name, FileFormat:=xlOpenXMLWorkbook 'New workbook save and activate

    '<ALL MY CODE THAT CHANGES THE NEW WORKBOOK>

    Excel.Workbooks(File_Name).Activate
    Excel.Workbooks(File_Name).Close savechanges:=True 'New workbook save and close
    Application.DisplayAlerts = True
    End If
    End Select
    If (Sheet_Archive.CodeName = "Sheet4" Or Sheet_Archive.CodeName = "Sheet5" _
    Or Sheet_Archive.CodeName = "Sheet6" Or Sheet_Archive.CodeName = "Sheet7") _
    And ShVal <> ShiftYear.Shift_3.Value Then
    PleaseWait.Label2.Caption = "" & Sheet_Archive.Name & " archive file complete"
    DoEvents
    Else: PleaseWait.Label2.Caption = "Initailizing archive ..."
    DoEvents: End If
    Next Sheet_Archive
ElseIf ShiftYear.CheckBox5.Value = False Then 'Archive <=5 year(s) data externally - Unchecked:
    'Do Nothing
End If 'Archive <=5 year(s) data externally - END

'<CONTINUING CODE THAT DOESN'T PERTAIN TO THE SAVEAS ISSUE>

Any solution to this is much appreciated!

Источник

Remove From My Forums

Question
Hello,
I am getting error 1004 — «SaveAs method of Workbook class failed» — from Workbook.SaveAs method. The error occurs regularly under specific conditions described below.

My application (MyApp) creates an instance of Excel.Application ActiveX object and after adding a workbook to the Excel.Application object and filling in its sheet saves the workbook by calling the SaveAs method. MyApp process gets created by a scheduler
application (SchedApp) which can run as a Windows service or a standard application.

If MyApp is spawned by SchedApp running as a Windows service, the call to the Workbook.SaveAs method fails returning 1004 — «SaveAs method of Workbook class failed».
If MyApp is spawned by SchedApp running as a standard application the call to Workbook.SaveAs method succeeds and produces .xsls file.

Following is the list of tests I have made so far to find out the cause of the SaveAs failure:

1) SchedApp as a service runs under Local System account (NT AUTHORITYSYSTEM). I changed the account under which the service runs to an account which belongs to Administrators group. The new account was the same account under which SchedApp runs as
a standard application when call to the SaveAs method succeeds. SaveAs method failed anyway.

2) Excel.Application and other Excel ActiveX objects are hosted by out-of-process COM server (EXCEL.EXE). This fact made me believe the cause of the SaveAs error is in privileges granted to the EXCEL.EXE out-of-process server which are too low to enable
the Workbook instance to write into the output path. In order to verify I created my own out-of-process COM server whose test object creates a file named identically to the .xsls file and in the same path as the path of .xsls file SaveAs is supposed to create.
I updated MyApp’s code to create an instance of the test object and attempt to create the output file. The test object successfully created and wrote arbitrary text to the .xsls file even if MyApp was spawned by SchedApp running as a service.

3) I changed the output path where SaveAs is supposed to create .xsls file to the temporary file folder specific for the account under which MyApp is running. SaveAs method failed anyway.

4) I changed element in EXCELL.EXE manifest file (excel.exe.manifest) from

<requestedExecutionLevel level=»asInvoker» uiAccess=»false»>
to

<requestedExecutionLevel level=»requireAdministrator» uiAccess=»false»>.

SaveAs method failed anyway.

5) In order to rule out possibility of the error being data dependent I removed the part of code in MyApp which fills in the Excel sheet so the output .xsls file would constitute an empty sheet. SaveAs method failed anyway.

6) I tested the aforementioned points (1-5) on Windows 2003 Server R2, Windows Vista, Windows 7, Windows 2012 R2. Save for Windows 2003 Server R2, the SaveAs method failed on all OSs — i.e. failed on Windows Vista, Windows 7, Windows 2012 R2. The only
exception was on Windows 2003 Server R2 where the SaveAs method succeeded no matter whether SchedApp was running as a service or a standard application.

The bottom line seems to be the Workbook.SaveAs method fails whenever MyApp process gets created by SchedApp running as a service (with the exception of Windows 2003 Server R2 mentioned in point 6).

Would you know why the SaveAs method fails when SchedApp is running as a service and hot to make it work?

Thank you,
Radovan

Answers

- Marked as answer by
  
  Thursday, October 13, 2016 8:33 AM

Источник

09-12-2014, 11:11 AM

#1

Registered User

Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

Hi Everyone
This Forum has been a life saver on numerous occasions.
The code that follows has been courtesy of this forum and the extensive help i received from everyone.

But after an year of using the following code it is giving me the following error:

Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

It worked for a while ( 1 year) and then suddenly failed.

A little background on the code.

The code basically is suppose to compare the system date (date on your computer) to a date on the excel file. If the system year is larger than date on the excel file then the system will complete a sort function and then save the file in the following locations

myPath = «S:AdminDocsFinancePurchasingCommonNon-Conforming POs-DatabaseArchive» in other words does a backup.

The system does the same for month and for date. So if system year is same as excel file year then we compare the month, and if month on the system is higher then the system does a sort and a backup.

That’s where the SaveAs runtime error comes in. As far as I know that’s where it is failing. I am a bit confused what is causing this problem.

I would really appreciate help, I am so frustrated.

Thanks

Last edited by Angsome; 09-12-2014 at 12:30 PM.
09-12-2014, 11:50 AM

#2

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

I think you need to change

FileFormat:=1

to

FileFormat:=51

Bernie Deitrick
Excel MVP 2000-2010
09-12-2014, 12:57 PM

#3

Registered User

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

Hi Bernie
Thanks for the reply

I have tried them all. Here is a list of alternatives I have tried thus far. Starting with the most recent. So 51 was my original number.

‘.SaveAs myPath

‘.SaveAs myPath, FileFormat:=0

‘.SaveAs «S:AdminDocsFinancePurchasingCommonNon-Conforming POs-DatabaseArchive1sName.xlsx»

‘ .SaveAs myPath _
& «» & sName & «.xlsx», _
FileFormat:=1

‘.SaveAs myPath _
& «» & sName & «.xlsx», _
FileFormat:=51

Hope this helps and I hope you can help out
09-12-2014, 01:30 PM

#4

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

Where is your macro located? Are you trying to save Thisworkbook?
09-12-2014, 02:36 PM

#5

Registered User

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

my location of folder location was wrong. Thanks for the advice everyone.
09-12-2014, 02:39 PM

#6

Registered User

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

how do i mark it as solved gentleman?
09-12-2014, 02:58 PM

#7

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

Click Thread Tools above your first post, select «Mark your thread as Solved». Or click the Edit button on your first post in the thread, Click Go Advanced, select [SOLVED] from the Prefix dropdown, then click Save Changes.

Источник

Within an excel workbook I have created a routine that automatically logs the user and date when the workbook is initially opened. The Sub Workbook_Open() calls the routine.

For most users it has worked effectively for sometime. However, myself and a few users are now getting the Run-time error ‘1004’ Method ‘SaveAs’ of object ‘_Workbook’ failed error message. The code is shown below. The log file is an excel (.xlsx) file held on a central Sharepoint site which all users have read and write access to. Any ideas to overcome would be greatly appreciated.

Sub LogDetails()
Dim LR As Long

Application.ScreenUpdating = False

Workbooks.Open Filename:=»http://…/Annual%20Statement%20Log/Log%20for%20Annual%20Statement.xlsx»
Set xls = CreateObject(«Excel.Application»)
xls.Application.DisplayAlerts = False

Workbooks(«Log for Annual Statement.xlsx»).Activate
Worksheets(«Log»).Activate
LR = Range(«A» & Rows.Count).End(xlUp).Row

Sheets(«Log»).Cells(LR + 1, 1) = (Environ$(«Username»))
Sheets(«Log»).Cells(LR + 1, 2) = Now()

Workbooks(«Log for Annual Statement.xlsx»).SaveAs Filename:=»http://…/Annual%20Statement%20Log/Log%20for%20Annual%20Statement.xlsx»
Workbooks(«Log for Annual Statement.xlsx»).Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Why are there 1,048,576 rows in Excel?

The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.

Have you considered using a hidden sheet in the workbook itself for the log ?
— your problem could not happen
The sheet can be hidden so that VBA is required to unhide it to prevent unhelpful user-meddling!

Thanks Yongle, that’s a good workaround. However, the workbook copies sheets across from another template workbook which is read only (to avoid damage to the templates and code) so each workbook is unique. That’s why I thought of having a separate simple workbook for the log.

Last edited: Oct 4, 2018

I solved the problem using the following code.

Sub LogDetails()
Dim LR As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Workbooks.Open Filename:=»http://…./Log%20for%20Annual%20Statement.xlsx»

Workbooks(«Log for Annual Statement.xlsx»).Activate
If ActiveWorkbook.ReadOnly Then ActiveWorkbook.LockServerFile
Worksheets(«Log»).Activate
LR = Range(«A» & Rows.Count).End(xlUp).Row

Sheets(«Log»).Cells(LR + 1, 1) = (Environ$(«Username»))
Sheets(«Log»).Cells(LR + 1, 2) = Now()

Workbooks(«Log for Annual Statement.xlsx»).Save
Workbooks(«Log for Annual Statement.xlsx»).Close

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Источник

03-03-2017, 07:52 AM

Run-time error ‘1004’: Method ‘SaveAs’ of object’_Workbook’ failed

Hello

I am trying to create a macro to take data from a worksheet and create and save separate workbooks based upon unique values in a specific column. I found some code which I managed to modify, (with help), and it gets to the point of creating the first workbook but it hangs on the SaveAs. I have tried researching file formats, etc., and changing the location where it saves but I am still getting this «

Run-time error ‘1004’: Method ‘SaveAs’ of object’_Workbook’ failed» error at this line: wb.SaveAs ThisWorkbook.Path & «C:Usersburls5DesktopCreated Files» & c.Value & «.xlsx»

Advice appreciated.
Sub splitCUbycolumn()
Dim wb As Workbook, sh As Worksheet, ssh As Worksheet, lr As Long, rng As Range, c As Range, lc As Long
Set sh = Sheets(1)
lr = sh.Cells(Rows.Count, "M").End(xlUp).Row
lc = sh.Cells.Find("*", , xlFormulas, xlPart, xlByColumns, xlPrevious).Column
sh.Range("A" & lr + 2).CurrentRegion.Clear
sh.Range("M1:M" & lr).AdvancedFilter xlFilterCopy, , sh.Range("A" & lr + 2), True
Set rng = sh.Range("A" & lr + 3, sh.Cells(Rows.Count, 1).End(xlUp))
    For Each c In rng
        Set wb = Workbooks.Add
        Set ssh = wb.Sheets(1)
        ssh.Name = c.Value
        sh.Range("A1", sh.Cells(lr, lc)).AutoFilter 12, c.Value
        sh.Range("A1", sh.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).Copy ssh.Range("A1")
        sh.AutoFilterMode = False
    wb.SaveAs ThisWorkbook.Path & "C:Usersburls5DesktopCreated Files" & c.Value & ".xlsx"
    wb.Close False
    Set wb = Nothing
    Next
sh.Range("A" & lr + 2, sh.Cells(Rows.Count, 1).End(xlUp)).Delete
End Sub

03-03-2017, 08:09 AM

#2
This puts the Path in twice
wb.SaveAs ThisWorkbook.Path & "C:Usersburls5DesktopCreated Files" & c.Value & ".xlsx"
Try something like this
MsgBox ThisWorkbook.Path & "Created Files" & c.Value & ".xlsx" (Delete when correct) wb.SaveAs ThisWorkbook.Path & "Created Files" & c.Value & ".xlsx"
———————————————————————————————————————

Paul

Remember: Tell us WHAT you want to do, not HOW you think you want to do it

1. Use [CODE] ….[/CODE ] Tags for readability
[CODE]PasteYourCodeHere[/CODE ] — (or paste your code, select it, click [#] button)
2. Upload an example
Go Advanced / Attachments — Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
3. Mark the thread as [Solved] when you have an answer
Thread Tools (on the top right corner, above the first message)
4. Read the Forum FAQ, especially the part about cross-posting in other forums
http://www.vbaexpress.com/forum/faq…._new_faq_item3
03-03-2017, 08:30 AM

#3

Thank-you, that worked perfectly!

Источник

Вопрос:

Я пытаюсь сохранить книгу Excel с макросами в виде файла csv, перезаписывая старую (ниже мне пришлось изменить имя папки и листа, но это не проблема).

 Sub SaveWorksheetsAsCsv()

Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long

CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
SaveToDirectory = "MyFolder"

Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False

Sheets("My_Sheet").Copy

ActiveWorkbook.SaveAs Filename:=SaveToDirectory & "My_Sheet" & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close SaveChanges:=False
ThisWorkbook.Activate

ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat

Application.DisplayAlerts = True
Application.AlertBeforeOverwriting = True

End Sub

Иногда это не с

Ошибка выполнения 1004: сбой метода метода объекта _workbook **)

Отладчик указывает:

 ActiveWorkbook.SaveAs Filename:=SaveToDirectory & "My_Sheet" & ".csv", FileFormat:=xlCSV

Я погуглил, и некоторые из решений, которые я попробовал, были:

Указывая, что каталог является строкой
Избегайте каких-либо специальных символов в имени файла или папки (см. Здесь)
Скопируйте и вставьте лист в качестве значения перед сохранением его в формате .csv (см. Здесь)
Указание FileFormat с кодом .csv (см. Здесь)
Отключение/повторное включение некоторых оповещений
Добавление других полей в строку ActiveWorkbook.SaveAs, касающихся паролей, создание резервных копий и т.д.

Тем не менее, он может работать правильно до 50-60 раз подряд, а затем в какой-то момент снова произойдет сбой.

Любое предложение, кроме как прекратить использование VBA/Excel для этой задачи, которая скоро произойдет, но пока не могу.

РЕДАКТИРОВАТЬ: Решено благодаря предложению Degustaf. Я внес только два изменения в предложенный Дегустафом код:

ThisWorkbook.Sheets вместо CurrentWorkbook.Sheets
FileFormat:=6 вместо FileFormat:=xlCSV (очевидно, более устойчив к различным версиям Excel)

Sub SaveWorksheetsAsCsv()

Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
Dim TempWB As Workbook

Set TempWB = Workbooks.Add

CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
SaveToDirectory = "\MyFolder"

Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False

ThisWorkbook.Sheets("My_Sheet").Copy Before:=TempWB.Sheets(1)
ThisWorkbook.Sheets("My_Sheet").SaveAs Filename:=SaveToDirectory & "My_Sheet" & ".csv", FileFormat:=6
TempWB.Close SaveChanges:=False

ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
ActiveWorkbook.Close SaveChanges:=False

Application.DisplayAlerts = True
Application.AlertBeforeOverwriting = True
End Sub

Лучший ответ:

Я обычно нахожу, что ActiveWorkbook является проблемой в этих случаях. Под этим я подразумеваю, что каким-то образом у вас не выбрана эта книга (или любая другая), а Excel не знает, что делать. К сожалению, поскольку copy ничего не возвращает (было бы неплохо скопировать лист), это стандартный способ решения этой проблемы.

Таким образом, мы можем подойти к этому как к тому, как мы можем скопировать этот лист в новую рабочую книгу и получить ссылку на эту рабочую книгу. Что мы можем сделать, это создать новую рабочую книгу, а затем скопировать лист:

Dim wkbk as Workbook

Set Wkbk = Workbooks.Add
CurrentWorkbook.Sheets("My_Sheet").Copy Before:=Wkbk.Sheets(1)
Wkbk.SaveAs Filename:=SaveToDirectory & "My_Sheet" & ".csv", FileFormat:=xlCSV
Wkbk.Close SaveChanges:=False

Или есть еще лучший подход в такой ситуации: WorkSheet поддерживает SaveAs метод. Копия не требуется.

CurrentWorkbook.Sheets("My_Sheet").SaveAs Filename:=SaveToDirectory & "My_Sheet" & ".csv", FileFormat:=xlCSV

Я предупрежу вас о том, чтобы впоследствии восстановить реальное имя книги, если она остается открытой, но она уже есть в вашем коде.

Ответ №1

Это год, но я добавлю что-то для будущих читателей.

Вы не найдете много документации в справочной системе Excel для ошибки времени выполнения 1004, поскольку Microsoft не считает ее ошибкой Excel.

Ответы выше 100% действительны, но иногда это помогает узнать, что вызывает проблему, поэтому вы можете избежать этого, исправить его раньше или исправить его легче.

Тот факт, что это прерывистая ошибка, и фиксируется путем сохранения с полным путем, и имя файла говорит мне, что либо ваш макрос может пытаться сохранить файл .xlsb в каталог автозавершения после автоматического восстановления файлов.

В качестве альтернативы вы можете сами отредактировать путь к файлу или имя файла.

Вы можете проверить путь и имя файла с помощью: –
MsgBox ThisWorkbook.FullName

В окне сообщения вы должны увидеть что-то подобное.

C:UsersMikeAppDataРоумингMicrosoftExcelDIARY (версия 1).xlxb

Если это решение (как указано выше другими), чтобы сохранить файл в правильном пути и имени файла. Это можно сделать с помощью VBA или вручную.

Теперь я привык вручную сохранять файл с правильным путем и именем файла, как само собой разумеющееся после любого действия по автообнаружению, так как он занимает несколько секунд, и я нахожу его быстрее (если это не ежедневное появление). Таким образом, макросы не будут сталкиваться с этой ошибкой, которую вы запускаете. Помните, что, хотя моя привычка вручную сохранять файлы .xlxb в .xlsm файлах сразу после восстановления не поможет новичку, которому вы даете рабочий лист.

Заметка о гиперссылках

После этой ошибки: если у вас есть гиперссылки на рабочем листе, созданные с помощью Ctrl + k, у вас будет что-то вроде “AppDataRoamingMicrosoft ”, “ AppDataRoaming”,.. /../AppData/Roaming/ “or”….Мои документыМои документы ” в нескольких гиперссылках после восстановления файла. Вы можете избежать этого, добавив свои гиперссылки в текстовое поле или создав их с помощью функции HYPERLINK.

Идентификация и восстановление их немного сложнее

Сначала рассмотрите гиперссылки и определите ошибочные строки и правильную строку для каждой ошибки. Со временем я нашел несколько.

Excel не предоставляет средства в меню “Перейти к специальному” для поиска гиперссылок, созданных с помощью Ctrl + k.

Вы можете автоматизировать идентификацию ошибочных гиперссылок в столбце помощника, например, столбец Z и используя формулу

=OR(ISNUMBER(SEARCH("Roaming", Link2Text($C2),1)),ISNUMBER(SEARCH("Roaming", Link2Text($D2),1)))

где Link2Text – это UDF

Функция Link2Text (rng As Range) As String “НЕ деактивируйте. ‘Определяет гиперссылки, содержащие” роуминг” в столбце Z.

' Identify affected hyperlinks
If rng(1).Hyperlinks.Count Then
Link2Text = rng.Hyperlinks(1).Address
End If

End Function

Мой VBA для исправления ошибок выглядит следующим образом

Sub Replace_roaming()

‘Выберите правильный лист Листы ( “ДНЕВНИК” ). Выберите

Dim hl As Hyperlink
For Each hl In ActiveSheet.Hyperlinks
hl.Address = Replace(hl.Address, "AppDataRoamingMicrosoft", "")
Next
For Each hl In ActiveSheet.Hyperlinks
hl.Address = Replace(hl.Address, "AppDataRoaming", "")
Next

For Each hl In ActiveSheet.Hyperlinks
hl.Address = Replace(hl.Address, "../../AppData/Roaming/", "....My documents")
Next
For Each hl In ActiveSheet.Hyperlinks
hl.Address = Replace(hl.Address, "....My documentsMy documents", "....My documents")
Next

Application.Run "Recalc_BT"

' Move down one active row to get off the heading
ActiveCell.Offset(1, 0).Select

' Check active row location
If ActiveCell.Row = 1 Then
ActiveCell.Offset(1, 0).Select
End If

' Recalc active row
ActiveCell.EntireRow.Calculate

' Notify
MsgBox "Replace roaming is now complete."

End Sub

Я также рекомендую вам привыкнуть к регулярным резервным копиям и не полагаться только на автообнаружение. Если это не удается, у вас нет ничего с момента последней полной резервной копии.

Хотя рабочий лист часто является хрупкой резервной копией, как каждый час или после значительного импорта новых данных.

Следующие ярлыки будут делать резервные копии рабочего листа в секундах: Ctrl + O, [выделить имя файла], Ctrl + C, Ctrl + V, [X]. Обычные резервные копии позволяют сразу перейти к самой последней резервной копии без необходимости восстановления из файла резервной копии прошлой ночью, особенно если вам нужно сделать запрос другого человека, чтобы сделать это.

Ответ №2

Попробуйте комбинировать путь и имя файла CSV в строковой переменной и отбросить .csv; который обрабатывается FileFormat. Путь должен быть абсолютным, начиная с буквы диска или имени сервера:   Dim strFullFileName as String  strFullFileName = "C:My FolderMy_Sheet"
Если на сервере он будет выглядеть примерно так:   strFullFileName = "\ServerNameShareNameMy FolderMy_Sheet"
Substiture ServerName с именем вашего сервера и замените ShareName на свою сеть. \data101AccountingMy FolderMy_Sheet  ActiveWorkbook.SaveAs Filename:=strFullFileName,FileFormat:=xlCSVMSDOS, CreateBackup:=False

Источник

Question

Answers

Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

Re: Runtime Error ‘1004’ Method ‘SaveAs’ of object’_Workbook Failed

Run-time error ‘1004’: Method ‘SaveAs’ of object’_Workbook’ failed

Заметка о гиперссылках