Excel VBA Saveas function corrupting file - excel

When I try to save my file with the ActiveWorkbook.Save function. The file get's corrupted and i cannot use it anymore.
I already tried the ActiveWorkbook.SaveCopyAs function, but the result is the same. Below the example. I have added the 2 other functions used on the bottom.
Sub Publish_WB()
Dim ws As Worksheet
Dim cell As Range
Dim CurrentPath, OriginalFname, NewFname, FName As String
If CheckPublished() Then
MsgBox ("Published version, feature not available ...")
Exit Sub
End If
NoUpdate
PublishInProgress = True
'Save the Current Workbook
OriginalFname = ActiveWorkbook.Path & "\" & ThisWorkbook.Name
'Store the current path
CurrentPath = CurDir
'Change the path to the same of the current sheet
SetCurrentDirectory ActiveWorkbook.Path
NewFname = Replace(ThisWorkbook.Name, ".xlsm", "_published.xlsm")
FName = Application.GetSaveAsFilename(FileFilter:="Excel files (*.xlsm),*.xlsm", InitialFileName:=NewFname, Title:="Save Published Version as")
If FName <> "" Then
ActiveWorkbook.SaveAs FName, 52
ActiveWorkbook.SaveCopyAs (OriginalFname)
Else
'user has cancelled
GoTo einde
End If
function CheckPublished()
Function CheckPublished() As Boolean
If Range("Quoting_Tool_Published").Value = True Then
CheckPublished = True
Else
CheckPublished = False
End If
End Function
and the NoUpdate :
Sub NoUpdate()
If NoUpdateNested = 0 Then
CurrentCalculationMode = Application.Calculation 'store previous mode
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'Application.Cursor = xlWait
NoUpdateNested = NoUpdateNested + 1
' Debug.Print "NoUpdate, Noupdatenested = " & NoUpdateNested
End Sub
if we jump to einde, I call the following function :
Sub UpdateAgain()
NoUpdateNested = NoUpdateNested - 1
If NoUpdateNested < 1 Then
Application.Calculation = xlCalculationAutomatic 'let all sheets be calculated again first
Application.Calculation = CurrentCalculationMode 'set to previous mode
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Cursor = xlDefault
Else
Application.Calculation = xlCalculationAutomatic 'recalculate sheets, but keep the rest from updating
Application.Calculation = xlCalculationManual
End If
'Debug.Print "UpdateAgain, Noupdatenested = " & NoUpdateNested
End Sub

By using a name for the workbook than rather activeworkbook I was able to solve the problem; the rest of the code is the same, so the rest was not causing any issues.
Sub Publish_WB()
Dim ws As Worksheet
Dim wb as Workbook
Dim cell As Range
Dim CurrentPath, OriginalFname, NewFname, FName As String
If CheckPublished() Then
MsgBox ("Published version, feature not available ...")
Exit Sub
End If
NoUpdate
PublishInProgress = True
'Save the Current Workbook
Set wb = ThisWorkbook
wb.Save
'Store the current path
CurrentPath = CurDir
'Change the path to the same of the current sheet
SetCurrentDirectory ActiveWorkbook.Path
NewFname = Replace(ThisWorkbook.Name, ".xlsm", "_published.xlsm")
FName = Application.GetSaveAsFilename(FileFilter:="Excel files (*.xlsm),*.xlsm", InitialFileName:=NewFname, Title:="Save Published Version as")
If FName <> "" Then
wb.SaveAs FName, 52
Else
'user has cancelled
GoTo einde
End If

Related

Workbook.Activate method

i got a variable:
V_WBNameOutPut as string
and use it inside the following code:
Application.Workbooks(V_WBNameOutPut).Activate
This two part of code are inside a huger code which work fine for 99.99% of different users, but only for one user the code go in error and when I debug its stop to Application.Workbooks(V_WBNameOutPut).Activate line.
And the error is the following:
Runtime Error 9: Subscript Out of Range
Any ideas why this happend and possible solution?
Thanks
I try it to debug but the code works fine but for one particular user it doesn't
The subroutine to generate the output file, which the Application.Workbooks(V_WBNameOutPut).Activate refers to:
Sub CreateWB()
Dim File_Name As Variant
Dim File_Name_Saved As String
Dim i_attempt As Integer
Dim NewWorkBook As Workbook
Set NewWorkBook = Workbooks.Add
Do While i_attempt < 2
i_attempt = i_attempt + 1
File_Name = Application.GetSaveAsFilename(InitialFileName:=V_WBNameOutPut, filefilter:="Excel Files(*.xlsx),*.xlsx,Excel-Macro Files (*.xlsm),*.xlsm", Title:="Please choose a Folder")
File_Name_Saved = Left(Right(File_Name, Len(V_WBNameOutPut) + 5), Len(V_WBNameOutPut))
If File_Name = False Then
ActiveWorkbook.Close
End
Else
If UCase(File_Name_Saved) <> UCase(V_WBNameOutPut) Then
If i_attempt < 2 Then
MsgBox "Please do not change the File name" & vbCrLf & i_attempt & "/2 Attempt"
Else
ActiveWorkbook.Close
End
End If
Else
Application.DisplayAlerts = False
NewWorkBook.SaveAs File_Name, ConflictResolution:=True
Exit Do
End If
End If
Loop
End Sub
You can loop through the open workbooks looking for a match without the file extension. A better solution would be to make CreateWB a function that returns the saved filename.
Option Explicit
Dim V_WBNameOutPut
Sub test()
Dim wb As Workbook
V_WBNameOutPut = "test2"
CreateWB
For Each wb In Workbooks
If wb.Name Like V_WBNameOutPut & "*" Then
wb.Activate
Exit For
End If
Next
Sheets(1).Cells(1, 1).Select ' active workbook
End Sub
Sub CreateWB()
Dim NewWorkBook As Workbook
Dim fso As Object, bSaveOK As Boolean, i_attempt As Integer
Dim File_Name As Variant, File_Name_Saved As String
Set fso = CreateObject("Scripting.FileSystemObject")
For i_attempt = 1 To 2
File_Name = Application.GetSaveAsFilename( _
InitialFileName:=V_WBNameOutPut, _
filefilter:="Excel Files(*.xlsx),*.xlsx,Excel-Macro Files (*.xlsm),*.xlsm", _
Title:="Please choose a Folder")
If File_Name = False Then Exit Sub
bSaveOK = (fso.getbasename(File_Name) = V_WBNameOutPut)
If Not bSaveOK And i_attempt = 1 Then
MsgBox "Please do not change the File name from " & V_WBNameOutPut _
& vbCrLf & i_attempt & "/2 Attempt"
Else
Exit For
End If
Next
' create workbook and save
If bSaveOK Then
Set NewWorkBook = Workbooks.Add
Application.DisplayAlerts = False
NewWorkBook.SaveAs File_Name, ConflictResolution:=True
Application.DisplayAlerts = True
End If
End Sub

Excel VBA - Multiple Dir() in Same Folder

I am working on this codes, but can't make it work.
Here is my working code:
Sub AREA21()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim regFile As String
Dim myExtension As String
Dim RegX As String
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
ThisWorkbook.UpdateLinks = xlUpdateLinksNever
myPath = "C:\Users\Aspire E 14\Desktop\xx\xxx\"
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*area trees yield of NFICCs in *.xls*"
RegX = "*area trees yield of NFICCs in REG*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
regFile = Dir(RegX & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
If myFile = regFile Then GoTo skipRegFile
Set wb = Workbooks.Open(Filename:=myPath & myFile, UpdateLinks:=False)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'my codes here
For i = 1 To Sheets.Count
Sheets(i).Select
Next i
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
skipRegFile:
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ThisWorkbook.UpdateLinks = xlUpdateLinksAlways
End Sub
Here is the sample folder:
Files with "REG**" are just the summary of respective provinces.
My goal is to run the codes in provincial files, and skip opening the file if it is a regional summary. However, problems occur when getting the next file in Dir statement as it appears blank.
Still looking for a better work around.
You can adapt this code to suit your needs.
Some suggestions:
Name your variables to something meaningful (sh is hard to understand, sourceRange it's easier)
Indent your code properly (you can use Rubberduckvba.com) to help you with data
Try to break your code into pieces (e.g. first validate, then prepare, then add items)
Comment your code
Code:
Public Sub Area21()
' Basic error handling
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
ThisWorkbook.UpdateLinks = xlUpdateLinksNever
' Define files path
Dim filesPath As String
filesPath = "C:\TEMP\"
' Define file name string to match
Dim fileString As String
fileString = "demo"
' Define file name
Dim fileName As String
fileName = Dir(filesPath, vbNormal)
' Loop through files
Do While fileName <> ""
'Set variable equal to opened workbook
If InStr(LCase(fileName), LCase(fileString)) > 0 Then
' Set a reference to the workbook
Dim targetWorkbook As Workbook
Set targetWorkbook = Workbooks.Open(fileName:=filesPath & fileName, UpdateLinks:=False)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
' DO SOMETHING WITH THE WORKBOOK
'Save and Close Workbook
targetWorkbook.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
End If
fileName = Dir()
Loop
CleanExit:
' Turn on stuff
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
ThisWorkbook.UpdateLinks = xlUpdateLinksAlways
Exit Sub
CleanFail:
MsgBox "Error " & Err.Description
GoTo CleanExit
End Sub

Run a specific macro in different workbook

I have a folder with more than 300+ excel files and what I want to open each of the excel files inside the folder and run specific macro that's already stored in each of the excel files, save it, close it and move to the next file.
The macro which is stored in each excel file is connected to other macros inside the workbook, you could call it like a Main macro, so for example If I just tried to run the Main macro, without the macros it's connected, to all the files at the same time, it just wouldn't work, because it is connected to other macros. The code below is what I've done so far, but it doesn't work as intended
Sub run_mYearChange
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim wb As Workbook, ws As Worksheet
Dim wPath As String, wQuan As Long, n As Long
Dim fso As Object, folder As Object, subfolder As Object, wFile As Object
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
wPath = .SelectedItems(1)
End With
Set fso = CreateObject("scripting.filesystemobject")
Set folder = fso.getfolder(wPath)
wQuan = folder.Files.Count
n = 1
For Each wFile In folder.Files
Application.StatusBar = "Processing folder : " & folder & ". File : " & n & " of : " & wQuan
If Right(wFile, 4) Like "*xlsm*" Then
Set wb = Workbooks.Open(wFile)
Application.Run "'C:\test2\*.xlsm*'!mYearChange.YearChangeFunction"
wb.Save True
wb.Close True
End If
n = n + 1
Next
Set fso = Nothing: Set folder = Nothing: Set wb = Nothing
MsgBox "End"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
I'm trying to find a solution everywhere and without luck. In this website there also hasn't been anything similar to what I'm asking. I would love all the help I could get, I'm kind of desperate, because nothing works.
Thank you for your help in advance.
You need to adjust the file name for each file opened.
Untested:
Sub run_mYearChange
'snipped....
Dim wPath As String, n As Long, f
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
wPath = .SelectedItems(1)
End With
if right(wPath, 1) <> "\" then wPath = wPath & "\"
f = Dir(wPath & "*.xlsm")
Do While Len(f) > 0
With Workbooks.Open(wPath & f)
Application.Run "'" & .Name & "'!mYearChange.YearChangeFunction"
.Close True 'save
End With
n = n + 1
f = Dir()
Loop
MsgBox "End"
'snipped...
End Sub

Excel Macro Doesn't Copy Worksheets to new Workbook

I have a macro that I partly created and pieced together from other codes. The intent of the the macro is to search all Excel files in my desktop folder called Financials -- it has approximately 25 files -- and to copy and paste into a new document all Worksheets that have the word (State) anywhere in the name; combine those Worksheets into 1 document and save the it my desktop folder called Final.
The code only saves a blank document to my folder and doesn't execute the other code
I have tried rearranging the code sequence
Sub CombineState()
Dim wbOpen As Workbook
Dim wbNew As Workbook
Const strPath As String = "C:\Users\johnson\Desktop\Financials"
Dim strExtension As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir strPath
strExtension = Dir("*.xlsx")
Set wbNew = Workbooks.Add
wbNew.SaveAs Filename:="C:\Users\johnson\Desktop\Final\Financial Metrics for State", FileFormat:=xlWorkbookNormal
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
Dim checkSheet As Worksheet
For Each checkSheet In wbOpen.Worksheets
If UCase$(checkSheet.Name) Like "*State*" Then
checkSheet.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
End If
Next
wbOpen.Close SaveChanges:=False
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub
Hypothetically speaking, if 3 documents contain State anywhere in the worksheet name, the new document will have 3 worksheets and be saved to my Final folder.
You were close. See the comment:
Sub CombineState()
Dim wbOpen As Workbook
Dim wbNew As Workbook
Const strPath As String = "C:\Users\johnson\Desktop\Financials\" ' Add the backslash at the end
Dim strExtension As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
ChDir strPath
strExtension = Dir("*.xlsx")
Set wbNew = Workbooks.Add
wbNew.SaveAs Filename:="C:\Users\johnson\Desktop\Final\Financial Metrics for State", FileFormat:=xlWorkbookNormal
Do While strExtension <> ""
Set wbOpen = Workbooks.Open(strPath & strExtension)
Dim checkSheet As Worksheet
For Each checkSheet In wbOpen.Worksheets
If UCase$(checkSheet.Name) Like "*STATE*" Then
checkSheet.Copy After:=wbNew.Sheets(wbNew.Sheets.Count)
wbNew.Sheets(wbNew.Sheets.Count).Name = wbNew.Sheets(wbNew.Sheets.Count).Cells(1, 1)
End If
Next
wbOpen.Close SaveChanges:=False
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub

How to reference the current User\Desktop location in VBA

Hello and thank you for your time, in the function code below, how do I make it in a way that it will function on any users computer, not just mine.
I know I need to probably use the Environ("USERPROFILE") thing but I don't know how to incorporate it in the code below.
Function Import_Data() As Boolean
Dim x As Workbook
Dim targetWorkbook As Workbook
Dim xWs As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Const F_PATH As String = "C:\Users\mohammad.reza\Desktop\MyFiles.xls"
'if no file then exit and return false
If Dir(F_PATH) = "" Then
MsgBox "My Files is not found on your Desktop"
Import_Data = False
Exit Function
End If
'If the file exists than load the file and continue
Import_Data = True
' This part delets all sheets except the summary tab
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Summary" Then
xWs.Delete
End If
Next
' This part will get the raw data from the downloaded file on the desktop
Set x = Workbooks.Open("C:\Users\mohammad.reza\Desktop\MyFiles.xls")
Set targetWorkbook = Application.ActiveWorkbook
' This part will copy the sheet into this workbook
With x.Sheets("MyFiles").UsedRange
ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Range("A1").Resize( _
.Rows.Count, .Columns.Count) = .Value
End With
x.Close
' This part will rename the sheet and move it to the end
ActiveSheet.Name = "RAW DATA"
ActiveSheet.Move After:=Worksheets(Worksheets.Count)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
Thank you brad for your answer, however when I use it, it gives the below error:
Try this ...
Function Import_Data() As Boolean
Dim x As Workbook
Dim targetWorkbook As Workbook
Dim xWs As Worksheet
Dim sPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sPath = Environ("USERPROFILE") & "\Desktop\MyFiles.xls"
'if no file then exit and return false
If Dir(sPath) = "" Then
MsgBox "My Files is not found on your Desktop"
Import_Data = False
Exit Function
End If
'If the file exists than load the file and continue
Import_Data = True
' This part delets all sheets except the summary tab
For Each xWs In Application.ActiveWorkbook.Worksheets
If xWs.Name <> "Summary" Then
xWs.Delete
End If
Next
' This part will get the raw data from the downloaded file on the desktop
Set x = Workbooks.Open(sPath)
Set targetWorkbook = Application.ActiveWorkbook
' This part will copy the sheet into this workbook
With x.Sheets("MyFiles").UsedRange
ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Range("A1").Resize( _
.Rows.Count, .Columns.Count) = .Value
End With
x.Close
' This part will rename the sheet and move it to the end
ActiveSheet.Name = "RAW DATA"
ActiveSheet.Move After:=Worksheets(Worksheets.Count)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function

Resources