I have a very extensive program written in Excel VBA that works perfectly fine, except when it attempts to save. Occasionally, not necessarily every time, the macro will save the workbook (in this case, export to CSV), but be stuck with the window labeled 'Saving,' a status message claiming that it's saving my file and a progress bar that will not progress further. It also has a button labeled 'Cancel,' which, when pressed, will continue the macro since the file has already been saved.
Here is the subroutine that I'm using:
Sub exportTable()
Dim varIsOpen As Boolean
Dim varSaveLocation1 As String, varSaveLocation2 As String
varIsOpen = False
If ThisWorkbook.Sheets("ControlSheet").Range("D2").Value = "" Then
varSaveLocation1 = ThisWorkbook.Path & "\CSVREVIEW\"
varSaveLocation2 = varSaveLocation1 & Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now)
Else
varSaveLocation1 = ThisWorkbook.Sheets("ControlSheet").Range("D2").Value
If Right(varSaveLocation1, 1) <> "\" Then varSaveLocation1 = varSaveLocation1 & "\"
varSaveLocation2 = varSaveLocation1 & Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now)
End If
For counter = 1 To Workbooks.Count
If Workbooks(counter).Name = "TableBook.xls" Then varIsOpen = True
If varIsOpen = True Then Exit For
Next
If varIsOpen = False Then GoTo isClosed
Workbooks("TableBook").Activate
'On Error Resume Next
If Len(Dir(varSaveLocation1, vbDirectory)) = 0 Then
MkDir varSaveLocation1
End If
If Len(Dir(varSaveLocation2, vbDirectory)) = 0 Then
MkDir varSaveLocation2
End If
'On Error GoTo 0
Application.DisplayAlerts = False
ActiveWorkbook.Sheets("test").Activate
ActiveWorkbook.SaveAs varSaveLocation2 + "\test", xlCSV
ActiveWorkbook.Sheets("part").Activate
ActiveWorkbook.SaveAs varSaveLocation2 + "\part", xlCSV
ActiveWorkbook.Sheets("logFile").Activate
ActiveWorkbook.SaveAs varSaveLocation2 + "\logFile", xlCSV
ActiveWorkbook.Sheets("deltaLimits").Activate
ActiveWorkbook.SaveAs varSaveLocation2 + "\deltaLimits", xlCSV
ActiveWorkbook.Close
Application.DisplayAlerts = True
isClosed:
End Sub
It may also be worth noting that I am currently saving to a server, but can't really remember if it did this while testing it on a local directory.
How can I get it to not hang? What is the cause of this problem and/or the solution to it?
I had this start happening to my sheet - a pair of doevents around the .saveas fixed this for me. I don't know why this is needed, or why it works, I saw it on a post (which I now cannot find).
It seems like the problem was actually just that it was saving to a server location. Saving locally ran the program flawlessly.
Thank you #TonyDallimore for the suggestion.
Related
I have the following code which is designed so I can quick save to my desktop and then put the file into a folder. This code works fine if the file is already saved in an .xls, .csv, .xlsx or .xlsm file extension, however, when the file IS NOT saved, I only get the pop-up message boxes, and nothing happens. I was thinking about re-structuring using a CASE STATEMENT with right(activeworkbook.name, 4), but didn't know how to structure as I am not familiar with these statements. Thank you.
Sub SavetoDesktop()
'this macro will save the activesheet into the default path giving it the current name and xlsx extension
Dim fname As String
' If Right(ActiveWorkbook.Name, 5) <> ".xlsx" And Right(ActiveWorkbook.Name, 5) <> ".xls" And _
' Right(ActiveWorkbook.Name, 5) <> ".xlsm" And Right(ActiveWorkbook.Name, 5) <> ".csv" Then
If Right(ActiveWorkbook.Name, 5) = ".xlsx" Then
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsx", "") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=fname
Else
MsgBox "Not an .xlsx file!"
ActiveWorkbook.SaveAs Filename:="C:\Users\mmirabelli\Desktop\" & ActiveWorkbook.Name & ".xlsx"
End If
If Right(ActiveWorkbook.Name, 4) = ".csv" Then
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".csv", "") & ".csv"
ActiveWorkbook.SaveAs Filename:=fname
Else
MsgBox "Not an .csv file!"
MsgBox ActiveWorkbook.Name
End If
If Right(ActiveWorkbook.Name, 4) = ".xls" Then
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xls", "") & ".xls"
ActiveWorkbook.SaveAs Filename:=fname
Else
MsgBox "Not an .xls file!"
End If
If Right(ActiveWorkbook.Name, 5) = ".xlsm" Then
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsm", "") & ".xlsm"
ActiveWorkbook.SaveAs Filename:=fname
Else
MsgBox "Not an .xlsm file!"
End If
' Else
'
' ActiveWorkbook.SaveAs Filename:="C:\Users\mmirabelli\Desktop\" & ActiveWorkbook.Name & ".xlsx"
' End If
'MsgBox Application.DefaultFilePath
'MsgBox ActiveWorkbook.Name
'
' ActiveWorkbook.SaveAs Filename:=fname
'
End Sub
thanks for the response. I tried this out and found the following: 1) The msgbox popped up when I tried saving Book1, and then it said "could not save" , and it did not save to desktop. For already saved files, I just got the "could not save" msgbox. I've never seen the "LIKE" and the "" syntax (at least in VBA, have seen in SQL). Is the like used for patterns in strings? and does the "" function as a wildcard for anything before or after? I also used a select case statement and found it was successful. I'll post below. Thanks again for the reply.
Sub SavetoDesktop()
'this macro will save the activesheet into the default path giving it the current name and xlsx extension,
' unless it already has an extension of the 4 most common formats, then it will simply save over
'(replace) the current file w a prompt
Dim fname As String
On Error GoTo errormessage
Select Case Right(ActiveWorkbook.Name, 4)
Case "xlsx"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsx", "") & ".xlsx"
ActiveWorkbook.SaveAs Filename:=fname
Case ".xls"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xls", "") & ".xls"
ActiveWorkbook.SaveAs Filename:=fname
Case "xlsm"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".xlsm", "") & ".xlsm"
ActiveWorkbook.SaveAs Filename:=fname
Case ".csv"
fname = Application.DefaultFilePath & "\" & Application.WorksheetFunction.Substitute(ActiveWorkbook.Name, ".csv", "") & ".csv"
ActiveWorkbook.SaveAs Filename:=fname
Case Else
MsgBox "Saved to desktop as .xlsx file!"
ActiveWorkbook.SaveAs Filename:="C:\Users\mmirabelli\Desktop\" & ActiveWorkbook.Name & ".xlsx"
End Select
Exit Sub
errormessage:
MsgBox "No action", vbInformation + vbOKCancel, Time()
End Sub
Is this what you are trying to do?
Sub SavetoDesktop()
'this macro will save the activesheet into the default path giving it the current name and xlsx extension
Dim fname As String
Select Case True
Case ActiveWorkbook.Name Like "*.xlsx", _
ActiveWorkbook.Name Like "*.xlsm", _
ActiveWorkbook.Name Like "*.xls", _
ActiveWorkbook.Name Like "*.csv"
fname = Application.DefaultFilePath & "\" & ActiveWorkbook.Name
Case Else
msgBox "No file extension. Will be saved as .xlsx in the Desktop folder"
fname = Environ$("HOMEDRIVE") & Environ$("HOMEPATH") & "\Desktop\" & ActiveWorkbook.Name & ".xlsx"
End Select
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=fname
msgBox IIf(Err.Number, "Could not Save", "Saved")
Application.DisplayAlerts = True
End Sub
I try to export single sheet as .txt file after refreshing querytable.
I don't want to use Workbooks.Add or .Copy and .PasteSpecial method.
So far, I've made this:
Do Until i = 5
With Sheets(2).QueryTables(1)
.Refresh BackgroundQuery:=False
End With
Sheets(2).SaveAs ThisWorkbook.path & filename & i & ".txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
i = i + 1
Loop
On first loop this works great, but on second i get errors.
Ok, I know what went wrong. Here is my original code:
Sub test()
Dim filename As String
Dim i As Integer
filename = "test_txt"
i = 0
Do Until i = 5
With Sheets(2).QueryTables(1)
.Refresh BackgroundQuery:=False
End With
Sheets(3).SaveAs ThisWorkbook.Path & "\FOLDER\" & filename & i & ".txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
i = i + 1
Loop
End Sub
Because i have ThisWorkbook.Path in loop, it changes every time I run it. Solution is simple - put ThisWorkbook.Path outsite the loop, like this:
Sub test()
Dim filename As String
Dim saveloc as String
Dim i As Integer
filename = "test_txt"
saveloc = ThisWorkbook.Path & "\FOLDER\"
i = 0
Do Until i = 5
With Sheets(2).QueryTables(1)
.Refresh BackgroundQuery:=False
End With
Sheets(3).SaveAs saveloc & filename & i & ".txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
i = i + 1
Loop
End Sub
Thanks #David Zemens for help!
Assuming Sheets(2) is part of ThisWorkbook, try the following:
Dim sep As String
sep = Application.PathSeparator
With ThisWorkbook
Do Until i = 5
.Sheets(2).QueryTables(1).Refresh BackgroundQuery:=False
.Sheets(2).SaveAs .path & sep & filename & i & ".txt", _
FileFormat:=xlTextMSDOS, CreateBackup:=False
i = i + 1
Loop
End With
I'm looking for a code to zip the folders of a path specified in my cells(1,1).value
After googling i found vba codes to zip the files of a folder but they are using WinZip.
My office machine does not have a WinZip installed and we are restricted to use WinZip. Could anyone please help with this. I need to use the default zip (Right click -> Send to compressed ZIP folder)
Thanks!
Sub Zip_File_Or_Files()
Dim strDate As String, DefPath As String, sFName As String
Dim oApp As Object, iCtr As Long, I As Integer
Dim FName, vArr, FileNameZip
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"
'Browse to the file(s), use the Ctrl key to select more files
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True, Title:="Select the files you want to zip")
If IsArray(FName) = False Then
'do nothing
Else
'Create empty Zip File
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
I = 0
For iCtr = LBound(FName) To UBound(FName)
vArr = Split97(FName(iCtr), "\")
sFName = vArr(UBound(vArr))
If bIsBookOpen(sFName) Then
MsgBox "You can't zip a file that is open!" & vbLf & _
"Please close it and try again: " & FName(iCtr)
Else
'Copy the file to the compressed folder
I = I + 1
oApp.Namespace(FileNameZip).CopyHere FName(iCtr)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = I
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
End If
Next iCtr
MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
Powered by Ron De Bruin - http://www.rondebruin.nl/win/s7/win001.htm
I have found it helpful to make a couple of tweaks to make this more friendly for the user (which for this sort of thing is often myself).
Limit how long you're willing to wait for the file & message the user if that time limit was reached without success
Add a DoEvents so that you can ctrl+break to pause the code in case you want to inspect (otherwise - can sometimes have to crash Excel, in my experience)
Add a statusbar update so the user knows what's going on
Sub ZipTheFile(ByVal strPath As String, ByVal strFileNameXls As String, ByVal strFileNameZip As String)
'Taken largely from Ron De Bruin - https://www.rondebruin.nl/win/s7/win001.htm
'Create empty Zip File
NewZip (strPath & strFileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(strPath & strFileNameZip).CopyHere strPath & strFileNameXls
'Keep script waiting until Compressing is done (OR we waited more than 40 seconds...)
On Error Resume Next
i = 0
Do Until oApp.Namespace(strPath & strFileNameZip).Items.Count = 1 Or i > 40 '<-- set how long you're willing to wait here
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents
Application.StatusBar = "Waiting for Zip - counter: " & i
i = i + 1
Loop
On Error GoTo 0
If i > 40 Then MsgBox "there seems to have been a problem putting the file into the zip foder. Check the zip at: " & strPath & strFileNameZip
End Sub
Sub NewZip(sPath) 'You need this sub-routine as well
'Create empty Zip File
'by Ron De Bruin - https://www.rondebruin.nl/win/s7/win001.htm
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
STILL Powered by Ron De Bruin - http://www.rondebruin.nl/win/s7/win001.htm
Background:
Several years ago, I made a spreadsheet to generate a list of samples to be tested each day. The user (usually me) checks boxes to indicate which tests' samples to list. Then the "save load sheet" button uses VBA to requery a database connection for sample information, populates the formatted list through a complex series of formulas, copies the values from the formula sheet ("Generator") to another sheet ("LoadSheet"), copies that sheet to a new workbook, and saves it with the date as filename in a folder according to year and month.
It worked pretty dependably for about 5 years, right up until a couple of weeks ago when my computer was upgraded from Windows 7 with Office 2013 to Windows 10 with Office 2016.
Problem:
Now, when I try to execute the code, I get Runtime error '1004: Copy method of Worksheet class failed."
Sub SaveAs()
'Copy to new workbook.
Sheets("LoadSheet").Copy '<---This is the line that fails.
' Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
'Save.
'If the worksheet already exists, the user will be asked whether to replace the file or not.
'If it already exists and is currently open, an error could arise.
'Hopefully that won't come up before I have time to think of a way to implement error handling.
ActiveWorkbook.SaveAs Filename:= _
"G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Range("A1").Select
Sheets(1).Select
Range("A1").Select
ActiveWorkbook.Save
Application.CutCopyMode = False
ThisWorkbook.Activate
Workbooks(Format(Now, "mm-dd-yy") & "x.xlsx").Activate
End Sub
This is the code that saves the file. It fails on the line indicated.
What I've already tried:
I've tried right-clicking on the worksheet tab, clicking "Move or Copy..." and try to create a copy in a new workbook. Nothing happens. No error message, no new worksheet/book, nothing.
Same thing happens if I try to "move" rather than "copy."
If I try right-clicking and creating a copy in the same workbook, I get a new blank sheet, rather than a copy.
I tried repairing my Office installation, but that didn't help.
I read about some cases where users suspected file corruption, so I even tried manually copying the contents to a new workbook by Ctrl+A,C,V one sheet at a time, and then doing the same for the code. No effect.
I tried Sheets(Worksheets.Count).Select followed by ActiveSheet.Copy, since the sheet is the last one in the book, but of course that didn't work.
I read that it could be because the workbook needed to be saved first, so I tried ActiveWorkbook.Save before the copy. Still the same result.
I tried decompiling/recompiling the worksheet to no effect.
It worked fine on Windows 7 with Office 2013 (and still does on a co-worker's Win7/Excel2013 machine), but I couldn't find anything online about problems with the Sheets.Copy method in Excel 2016, so I don't know if either of those is relevant.
Any ideas?
EDIT: I've tried it on an identical computer (also running Windows 10 & Office 2016) and had the same result. I'm not sure how commonly an installation becomes corrupted, but this feels like more than coincidence. The other computer is rarely used by anyone, and it's being used primarily to run an instance of SQL Server Express and a Windows service I wrote, so I suspect that makes corruption even less likely.
I've got a workaround for now... I just save the file with the filename and path I would have used for the copy, then do a For Each on each worksheet, deleting anything not named "LoadSheet."
Sub SaveAs()
On Error GoTo SaveAs_Err
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then '<> "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then '<> "G:\Load Sheets\" & Year(Now) & "\" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
' Turn off alerts. They're annoying. I don't care if it's poor form, I just want to be done with this. I'm not being paid to write code.
Application.DisplayAlerts = False
'Save, disregarding consequences.
ActiveWorkbook.SaveAs Filename:= _
"G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' Remove extraneous sheets.
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> "LoadSheet" Then ws.Delete
Next
Application.DisplayAlerts = True
Exit Sub
SaveAs_Err:
Application.DisplayAlerts = True
MsgBox ("An error occurred while saving the file.")
Debug.Print "Error " & Err.Number & ": " & Err.Description
End Sub
I'm still interested in fixing the root cause of this problem, so if anyone has ideas, I'm all ears! I'll probably still try the uninstall/reinstall, but I don't expect it to change anything.
Brute force fix, try:
Sub SaveAs()
Dim newWB as Workbook, i as Integer, copyRange as Range, fName as String
Set newWB = Workbooks.Add
While newWB.Worksheets.Count > 1
newWB.Worksheets(newWB.Worksheets.Count).Delete
Wend
newWB.Worksheets(1).Name = "LoadSheet"
' get a handle on the sheet's usedRange object
Set copyRange = ThisWorkbook.Worksheets("LoadSheet").UsedRange
' assign the values to the newWB.Worksheets(1)
'newWB.Worksheets(1).Range(copyRange.Address).Value = copyRange.Value
copyRange.Copy Destination:=newWB.Worksheets(1).Range(copyRange.Address)
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
fName = "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x"
If Dir(fName & ".xlsx") <> "" Then Kill fName & ".xlsx"
If Dir(fName & ".xlsm") <> "" Then Kill fName & ".xlsm"
newWB.SaveAs Filename:= fName, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Workbooks.Open(fName)
End Sub
Alternatively, use the SaveAs method of the Worksheets class:
Sub SaveAs()
Dim fName as String
'Check directory, create if necessary.
If Dir("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\", vbDirectory) = "" Then
If Dir("G:\Load Sheets\" & Year(Now) & "\", vbDirectory) = "" Then
MkDir ("G:\Load Sheets\" & Year(Now) & "\")
End If
MkDir ("G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\")
End If
fName = "G:\Load Sheets\" & Year(Now) & "\" & MonthName(Month(Now)) & "\" & Format(Now, "mm-dd-yy") & "x"
If Dir(fName & ".xlsx") <> "" Then Kill fName & ".xlsx"
If Dir(fName & ".xlsm") <> "" Then Kill fName & ".xlsm"
ThisWorkbook.Worksheets("LoadSheet").SaveAs Filename:= fName, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Save
Application.CutCopyMode = False
Workbooks.Open(fName)
End Sub
I've also revised both solutions to avoid the potential error you comment:
If it already exists and is currently open, an error could arise.
I would work with your IT and/or MS support on the specific failure of the .Copy method, though, it's almost certainly a problem with your installation and may result in nastier errors in the future.
Hey I fairly new at Excel and I am running into a problem with error handing. I want my macro to run and if it can not find the folder then it should produce a message to the users and exit sub. Any help would be greatly appreciated!
Below is my code on where my macro saves file
Worksheets("Input data").Visible = True
folder = "\\Group_SHARED\Group Shared\Engineering\Controlled Folder\Number_Checkout\Archived\Archived"
MyTime = Time
Sheets("Input data").Select
Range("G2").Value = MyTime
strFileName = folder & "_" & Sheets("Input data").Range("C6").Value & "_" & Sheets("Get_ECN").Range("B6").Value & "_" & Sheets("Input data").Range("C3").Value & " " & Sheets("Input data").Range("C4").Value
Worksheets("Input data").Visible = False
ActiveWorkbook.SaveAs Filename:=strFileName
Try:
If dir(folder) = "" then
Msgbox "no such directory"
Exit sub
end if
as in:
Sub Test()
folder = "C:\Users\Administrator\"
If Dir(folder) = "" Then
MsgBox "no such directory"
Exit Sub
Else
MsgBox "Yup, It's There All Right."
End If
End Sub