I'm having some trouble getting something pretty basic to work. Any ideas what's wrong here?
Sub Test()
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Master List").SaveAs "C:\Test\ART.xlsx", 52
Application.DisplayAlerts = True
End Sub
Export Worksheet
Option Explicit
Sub exportSheet()
Const FolderPath As String = "C:\Test\"
Const FileName As String = "ART.xlsx"
Const SheetName As String = "Master List"
On Error Resume Next
Workbooks(FileName).Close
On Error GoTo 0
With ThisWorkbook
Application.ScreenUpdating = False
.Sheets(SheetName).Copy
With ActiveWorkbook
Application.DisplayAlerts = False
.SaveAs FolderPath & FileName, xlOpenXMLWorkbook ' 51 (.xlsx)
Application.DisplayAlerts = True
.Close False
End With
' Open Folder Path in Windows File Explorer.
'.FollowHyperlink FolderPath
'.Close
Application.ScreenUpdating = True
End With
End Sub
Related
I am trying to build a data formatter where the user selects a file of type .xlsx and then I format it and save it as type .csv. I am needing to convert the xlsx file to a csv before I can format it. To do this, I couldn't find anything apart from opening the file, copying the used range to a worksheet on the original file, saving that worksheet as csv and then referencing that file. Despite a lack of elegance, this would work fine for the use case. However, I cannot seem to get the copying of the worksheet to be formatted down.
Here's what I'm trying for copying:
Dim active As Worksheet
Set active = ActiveSheet
With Workbooks.Open(myFile)
ActiveSheet.UsedRange.Copy
active.Paste
.Close SaveChanges:=False
End With
This, in theory, should copy the data from the file being opened to the already opened file, but it doesn't.
This works great for me:
As a sub:
Sub ConvertToCSV()
Dim MyFile As String
Dim WBtmp As Workbook
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
MyFile = "C:\Users\cameron\Documents\IDs.xlsx"
Set WBtmp = Workbooks.Open(MyFile)
With WBtmp
.SaveAs Replace(MyFile, ".xlsx", ""), xlCSV
.Close
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Or as a function
Sub TestFunc()
fConvertToCSV "C:\Users\cameron\Documents\IDs.xlsx"
End Sub
Function fConvertToCSV(MyFile As String)
Dim WBtmp As Workbook
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set WBtmp = Workbooks.Open(MyFile)
With WBtmp
.SaveAs Replace(MyFile, ".xlsx", ""), xlCSV
.Close
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Function
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
I was hoping to save my new csv file sheet1 as "CSV123" but somehow the sheet name is always changed to filename after I save and close the file.
I am not sure why the .Sheets(1).Name = "CSV123" is registered when I use F8 to check but does not register after I close the workbook.
Sub Save_as_CSV()
Dim Newbook As Workbook
Dim filename As String
Dim answer As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
answer = InputBox("Please enter the file name for save", "CSV File Name")
If answer <> "" Then
filename = Application.ThisWorkbook.Path & "\" & answer & ".csv"
Set Newbook = Workbooks.Add
shcsv.Copy before:=Newbook.Sheets(1)
With Newbook
.Sheets(1).Rows("1:3").Delete
.SaveAs filename:=filename, FileFormat:=Excel.xlCSV
.Sheets(1).Name = "CSV123"
.Save
.Close
End With
Else
Exit Sub
End If
MsgBox "The CSV is exported to the same directory as this file."
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
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
I save all worksheets in a workbook as individual CSV files.
If I make a change to any of the worksheets and run the macro again, it prompts me with the "A file named ... already exists in this location. Do you want to replace it?".
If I click Yes, the prompt comes up for every worksheet. If I click no, the macro throws an error.
Is there a way to avoid the prompt?
Sub CSVAutomation()
Dim ws As Worksheet, wb As Workbook
Dim pathh As Variant
Set wb = ActiveWorkbook
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then 'a folder was picked
pathh = .SelectedItems(1)
End If
End With
If pathh = False Then Exit Sub 'no folder picked; pathh is false
Application.ScreenUpdating = False
For Each ws In wb.Sheets(Array("01 - Currencies", ...."14 - User Defined
Fields"))
ws.Copy
With ActiveWorkbook
'Application.DisplayAlerts = False 'to avoid overwrite warnings
' pathh is a string (variant) of the path of the folder; does not
need pathh.Path
.SaveAs pathh & "\" & ws.Name, xlCSV
.Close SaveChanges:=False
End With
Next ws
Application.ScreenUpdating = True
End Sub
Check my comment and (as Portland Runner says) you could turn off some alerts
I used this
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Application.AskToUpdateLinks = False
Using a procedure to put inside and used every time to turn it of and another to turned on helpme a lot with all the alerts.
Sub Alerts(ScreenUpdate As Boolean, DisplayAlerts As Boolean, AutoSecurity As Boolean, AskToUpdate As Boolean)
Application.ScreenUpdating = ScreenUpdate
Application.DisplayAlerts = DisplayAlerts
Application.AutomationSecurity = IIf(AutoSecurity, msoAutomationSecurityForceDisable, msoAutomationSecurityByUI)
Application.AskToUpdateLinks = AskToUpdate
End Sub