savePath = "\\local drive path"
myFileName = savePath & "Workbook Name " & saveDate
Application.DisplayAlerts = False
'MsgBox (myFileName)
wbTarget.Activate
ActiveWorkbook.SaveAs Filename:=myFileName, FileFormat:=xlOpenXMLWorkbook
When using the above code, I get an error 1004 "Method SaveAs of object_Workbook failed and can't figure out why. I'm relatively new to excel but belive I have everything set up right.
Update: Sorry should have shown the more complete code.
Sub SaveAs()
'Save As "Workbook Name"
Dim wbTarget As Workbook
Dim wbThis As Workbook
Dim strName As String
Set wbTarget = Workbooks("Workbook Name")
wbTarget.Activate
Dim myFileName As String
Dim saveDate As String
Dim saveMonth As String
Dim monthNum As String
Dim savePath As String
Sheets("Raw").Select
saveDate = Range("A2").Value
saveMonth = Range("A2").Value
monthNum = Range("A2").Value
savePath = "\\local drive path"
myFileName = savePath & "Riskviews Data " & saveDate
Application.DisplayAlerts = False
'MsgBox (myFileName)
wbTarget.SaveAs Filename:=myFileName, FileFormat:=xlOpenXMLWorkbook
End Sub
I updated the last part to say "wbTarget.SaveAs" but that didn't seem to work.
The problem may be with ActiveWorkBook. You should try to avoid relying on .Active, .Activate, and .Select when you can simply refer to your objects directly.
Delete wbTarget.Activate and try the below,
WbTarget.SaveAs Filename:=myFileName, FileFormat:=xlOpenXMLWorkbook
I can see you have tried to debug. MsgBox myFileName (notice: no ()) should have displayed what you are passing to the save command. From your code above, it would be \\local drive pathWorkbook Name - noting that there is a space at the end as well. You have not defined saveDate, you have not added an extension and you have not indicated the file format.
See the following answers for further information to SaveAs.
How to do a "Save As" in vba code, saving my current Excel workbook with datestamp?
Related
I am getting a 1004 error when I try and combine workbook pages into one master document. The code works correctly on my device, but when I attempt to run the code on my friends device it throw a 1004 error. I believe he is on excel 2013, I am on excel 2016. Is there any way to convert my code into something that can be used on both devices?
Sub CombineSheets()
Dim sPath As String
Dim sFname As String
Dim wBk As Workbook
Dim wSht As Variant
Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = InputBox("Enter a full path to workbooks")
ChDir sPath
sFname = InputBox("Enter a filename pattern")
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal)
wSht = InputBox("Enter a worksheet name to copy")
Do Until sFname = ""
Set wBk = Workbooks.Open(sFname)
Windows(sFname).Activate
Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1)
wBk.Close False
sFname = Dir()
Loop
ActiveWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
This works correctly when I run it, prompts for the folder location, asks which files it should copy from (usually *), and then copies from specifically the worksheet name entered.
Realistically all I need is code that can extract one worksheet from several hundred excel files and combine them into one master document. being able to pick and choose which worksheets would just be a bonus.
Thank you!
Like Mat's Mug said, you should really validate you inputs.
Did your co-worker add a "\" at the end of the path? Does the Path even exist?
Test to make sure that the sheet exists in the file that you are copying from, with something like this:
Function SheetExists(Name As String, Optional Workbook As Excel.Workbook = Nothing) As Boolean
If Workbook Is Nothing Then Set Workbook = ThisWorkbook.Application.ActiveWorkbook
On Error Resume Next
If Workbook.Worksheets(Name).Name <> vbNullString Then
End If
If Err.Number = 0 Then SheetExists = True
On Error GoTo 0
End Function
Here is your code with the noted changes:
Sub CombineSheets()
Dim sPath As String
Dim sFname As String
Dim wBk As Workbook
Dim sSht As String
Application.EnableEvents = False
Application.ScreenUpdating = False
sPath = InputBox("Enter a full path to workbooks")
'Use the FolderPicker to verify the path
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then sPath = .SelectedItems(1)
End With
'ChDir sPath
sFname = InputBox("Enter a filename pattern")
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal)
sSht = InputBox("Enter a worksheet name to copy")
Do Until sFname = ""
Set wBk = Workbooks.Open(sFname)
'Windows(sFname).Activate
If SheetExists(sSht, wBk) Then
wBk.Sheets(sSht).Copy Before:=ThisWorkbook.Sheets(1)
End If
wBk.Close False
sFname = Dir()
Loop
'ActiveWorkbook.Save
ThisWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
The bigger question is, are the Sheets the same size? Old .xls files only have 65536 rows, where 2007+ .xlsx files go up to 1048576 rows.
You can't mix the two different worksheets. In that case, you need to copy all of the cells from one sheet to the other.
wBk.Sheets(sSht).Cells.Copy
ThisWorkbook.Sheets.Add Before:=ThisWorkbook.Sheets(1)
ThisWorkbook.Sheets(1).Paste
Here's the code I have for renaming a file. It does a SaveAs and then deletes the original. This needs to be ran on different types of workbooks: some have a .xls extension, others have a .xlsx extension. If it has a .xls extension, I need to force it to have a .xlsx extension somehow.
How can I do this other than by manually typing an "x" at the end of the blank in the InputBox when it pops up?
Or maybe there's a different solution to this problem? My goal is to force the InputBox to show the current filename with a .xlsx extension regardless of what is currently is.
Sub RenameFile()
Dim myValue As Variant
Dim thisWb As Workbook
Set thisWb = ActiveWorkbook
MyOldName2 = ActiveWorkbook.Name
MyOldName = ActiveWorkbook.FullName
MyNewName = InputBox("Do you want to rename this file?", "File Name", _
ActiveWorkbook.Name)
If MyNewName = vbNullString Then Exit Sub
If MyOldName2 = MyNewName Then Exit Sub
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=thisWb.Path & "\" & MyNewName, _
FileFormat:=51
Kill MyOldName
End Sub
If the new extension is always going to be .xlsx, why not leave the extension out of the input box entirely:
Dim fso As New Scripting.FileSystemObject
MyNewName = InputBox("Do you want to rename this file?", "File Name", _
fso.GetBaseName(ActiveWorkbook.Name)) & ".xlsx"
Note that this requires a refernece to Microsoft Scripting Runtime.
Do you want to present the extension at the point of the MsgBox or after? The following code will force the extension to be changed to whatever type you specify. Just add code for other conversions you want to handle. If you want to present the new extension in the Msgbox, copy the code I added and place before the MsgBox. If you want to 'guarantee' new extension, you need to keep the code after the Msgbox in case user overrules your suggestion.
Sub RenameFile()
Dim myValue As Variant
Dim thisWb As Workbook
Dim iOld As Integer
Dim iNew As Integer
Dim iType As Integer
Set thisWb = ActiveWorkbook
Dim MyOldName2, MyOldName, MyNewName As String
MyOldName2 = ActiveWorkbook.Name
MyOldName = ActiveWorkbook.FullName
MyNewName = InputBox("Do you want to rename this file?", "File Name", _
ActiveWorkbook.Name)
If MyNewName = vbNullString Then Exit Sub
If MyOldName2 = MyNewName Then Exit Sub
iOld = InStrRev(MyOldName, ".")
iNew = InStrRev(MyNewName, ".")
If LCase(Mid(MyOldName, iOld)) = ".xls" Then
MyNewName = Left(MyNewName, iNew - 1) & ".xlsx"
iType = 51
ElseIf LCase(Mid(MyOldName, iOld + 1)) = ".YYYY" Then ' Add lines as needed for other types
MyNewName = Left(MyNewName, iNew - 1) & ".ZZZZ" ' Must change type to match desired output type
iType = 9999
Else
MsgBox "Add code to handle extension name of '" & LCase(Mid(MyOldName, iOld)) & "'", vbOKOnly, "Add Code"
Exit Sub
End If
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=thisWb.Path & "\" & MyNewName, FileFormat:=iType
Kill MyOldName
End Sub
I have a code that copies two worksheets from one workbook to a new one.
Since those two worksheets contain graphs where the data is on the sheet itself, but the datacells refer to a different worksheet, I copy the values only, to avoid external links.
However I found out that there is still an external link to my original workbook.
I don't know where it is though, since there are no formulas anymore.
I thought about names and deleted them as well, since there were a lot of names, that didn't even exist in the original file. That didn't help either.
I can delete the external, when using the menu in the ribbon.
And the code below also works, when I use it in the new workbook itself when opening it and running it in there.
Sub BreakLinks()
Dim wb As Workbook
Set wb = Application.ActiveWorkbook
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
For Each link In wb.LinkSources(xlExcelLinks)
wb.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
End Sub
However, if I want to use that code in conjunction with the copying, it does not do the trick. I saved it on purpose before breaking the link, because I thought it might not be able to do it, but it didn't help.
Does anybody know why it doesn't work or can point me to a solution?
Here's the complete code:
Sub ACTION_Export_Capex()
Dim Pfad As String
Dim Dateiname As String
Dim ws As Worksheet
Dim wb As Workbook
Pfad = "D:\#Inbox\"
Dateiname = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " & "monthly Report-" & Format(DateSerial(Year(Date), Month(Date) - 1, 1), "yyyy-mm") & " Capex" & ".xlsx"
'Copy Sheets without formulas
Sheets(Array("Capex_monthly", "Capex_YTD")).Copy
For Each ws In Worksheets
ws.UsedRange = ws.UsedRange.Value
Next
'get rid of macrobuttons and hyperlinks
For Each ws In Worksheets
ws.Rectangles.Delete
ws.Hyperlinks.Delete
Next
ActiveWorkbook.SaveAs Filename:=Pfad & Dateiname, FileFormat:=xlOpenXMLWorkbook
'delete external links
If Not IsEmpty(ActiveWorkbook.LinkSources(xlExcelLinks)) Then
For Each link In ActiveWorkbook.LinkSources(xlExcelLinks)
ActiveWorkbook.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
ActiveWorkbook.Save
ActiveWorkbook.Close
'go back to main menu in Cockpit
Sheets("Menu").Select
End Sub
Thanks a lot in advance.
EDIT:
In the end brettdj got the solution, I just had to tweak it a bit to get it done in my workbook.
Here's the code:
Sub ACTION_Export_Capex()
Dim Pfad As String
Dim Dateiname As String
Dim ws As Worksheet
Dim wb As Workbook
Pfad = "D:\#Inbox\"
Dateiname = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " & "monthly Report-" & Format(DateSerial(Year(Date), Month(Date) - 1, 1), "yyyy-mm") & " Capex" & ".xlsx"
'Copy Sheets without formulas
Sheets(Array("Capex_monthly", "Capex_YTD")).Copy
For Each ws In Worksheets
ws.UsedRange = ws.UsedRange.Value
Next
'get rid of macrobuttons and hyperlinks
For Each ws In Worksheets
ws.Rectangles.Delete
ws.Hyperlinks.Delete
Next
'get rid of external link
ActiveWorkbook.ChangeLink ThisWorkbook.Name, ActiveWorkbook.Name, xlLinkTypeExcelLinks
ActiveWorkbook.SaveAs Filename:=Pfad & Dateiname, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
Sheets("Menu").Select
End Sub
If I use this code the links are gone when the new worbook is opened again.
I am still puzzled why the original creation builds in a phantom link that exists even when the two copied sheets are deleted.
code
Sub Test()
Dim wb As Workbook
Dim wb2 As Workbook
Dim Pfad As String
Dim Dateiname As String
Dim ws As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = falser
End With
Pfad = "D:\#Inbox\"
'Pfad = "c:\temp\"
Dateiname = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " & "monthly Report-" & Format(DateSerial(Year(Date), Month(Date) - 1, 1), "yyyy-mm") & " Capex" & ".xlsx"
Set wb = ThisWorkbook
Set wb2 = Workbooks.Add(1)
wb.Sheets(Array("Capex_monthly", "Capex_YTD")).Copy After:=wb2.Sheets(1)
wb2.Sheets(1).Delete
wb2.SaveAs Filename:=Pfad & Dateiname, FileFormat:=xlOpenXMLWorkbook
wb2.ChangeLink wb.Name, wb2.Name, xlLinkTypeExcelLinks
wb2.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Goto wb.Sheets("Menu").[a1]
End With
Set wb2 = Workbooks.Open(Pfad & Dateiname)
End Sub
I've created a excel spreadsheet template for our customers to populate and send back to us. I want to manually select their populated data and save it as a .csv to import into another piece of software. I, first, attempted this by recording a macro. This didn't work because different customers send different numbers of records.
I've tried snippets of code from online research and came up with this.
Sub Select_To_CSV()
Dim rng As Range
Dim myrangearea()
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Dim myPath As String, v
myPath = "p:\" & _
Format(Date, "yyyymmdd") & ".csv"
'myPath = "x:\" & Format(Date, "yyyymmdd") & ".csv"
v = SaveAs(myPath)
If v <> False Then ThisWorkbook.SaveAs v
End Sub
Function SaveAs(initialFilename As String)
On Error GoTo EndNow
SaveAs = False
With Application.FileDialog(msoFileDialogSaveAs)
.AllowMultiSelect = False
.ButtonName = "&Save As"
.initialFilename = initialFilename
.Title = "File Save As"
'.Execute
.Show
SaveAs = .SelectedItems(1)
End With
EndNow:
End Function
Sub Select_To_CSV()
Dim rng As Range
Dim myrangearea()
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Dim myPath As String, v
myPath = "p:\" & _
Format(Date, "yyyymmdd") & ".csv"
'myPath = "x:\" & Format(Date, "yyyymmdd") & ".csv"
v = SaveAs(myPath)
If v <> False Then ThisWorkbook.SaveAs v
End Sub
This worked really well except when I went back to look at the .csv in the folder it was the same worksheet not the selected columns.
Ultimately what I am looking to do is,
Manually select the columns I want
Run a macro that converts the selected columns to a .csv
Have the Save As Dialog Box appear
Navigate to the certain folder I want.
Here you go:
Sub MacroMan()
ChDrive "P:" '// <~~ change current drive to P:\
Dim copyRng As Excel.Range
Dim ThisWB As Excel.Workbook
Dim OtherWB As Excel.Workbook
Dim sName As String
'// set reference to the 'Master' workbook
Set ThisWB = ActiveWorkbook
'// assign selected range to 'copyRng'
Set copyRng = Application.InputBox(Prompt:="Select range to convert to CSV", Type:=8)
'// If the user selected a range, then proceed with rest of code:
If Not copyRng Is Nothing Then
'// Create a new workbook with 1 sheet.
Set OtherWB = Workbooks.Add(1)
'// Get A1, then expand this 'selection' to the same size as copyRng.
'// Then assign the value of copyRng to this area (similar to copy/paste)
OtherWB.Sheets(1).Range("A1").Resize(copyRng.Rows.Count, copyRng.Columns.Count).Value = copyRng.Value
'// Get save name for CSV file.
sName = Application.GetSaveAsFilename(FileFilter:="CSV files (*.csv), *.csv")
'// If the user entered a save name then proceed:
If Not LCase(sName) = "false" Then
'// Turn off alerts
Application.DisplayAlerts = False
'// Save the 'copy' workbook as a CSV file
OtherWB.SaveAs sName, xlCSV
'// Close the 'copy' workbook
OtherWB.Close
'// Turn alerts back on
Application.DisplayAlerts = True
End If
'// Make the 'Master' workbook the active workbook again
ThisWB.Activate
MsgBox "Conversion complete", vbInformation
End If
End Sub
This will allow you to manually select a range (including entire columns). It will then transfer said range onto a new sheet, save that sheet as a CSV, using the Save As dialog, and then close it afterwards.
This question already has answers here:
Export each sheet to a separate csv file
(2 answers)
Closed 8 years ago.
I am very new with VB coding, I am trying to save multiple excel file worksheets to csv, I don't know to do this for multiple sheets, but I found a way to do for single file. I have found code on this site which are very useful for what I am trying to do, only problem is the files are saved with the worksheet name but I am trying to save them with the original file and worksheet name such as filename_worksheet name, I tried to do that myself but keep getting error, could you please advise what I am doing wrong?
The code I am using is as follows:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook
SaveToDirectory = "H:\test\"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = True
' Temporarily turn alerts off to prevent the user being prompted
' about overwriting the original file.
End Sub
I think this is what you want...
Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook
SaveToDirectory = "H:\test\"
For Each WS In Application.ActiveWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = True
' Temporarily turn alerts off to prevent the user being prompted
' about overwriting the original file.
End Sub
I had a similar problem. Data in a worksheet I needed to save as a separate CSV file.
Here's my code behind a command button
Private Sub cmdSave()
Dim sFileName As String
Dim WB As Workbook
Application.DisplayAlerts = False
sFileName = "MyFileName.csv"
'Copy the contents of required sheet ready to paste into the new CSV
Sheets(1).Range("A1:T85").Copy 'Define your own range
'Open a new XLS workbook, save it as the file name
Set WB = Workbooks.Add
With WB
.Title = "MyTitle"
.Subject = "MySubject"
.Sheets(1).Select
ActiveSheet.Paste
.SaveAs "MyDirectory\" & sFileName, xlCSV
.Close
End With
Application.DisplayAlerts = True
End Sub
This works for me :-)
Is this what you are trying?
Option Explicit
Public Sub SaveWorksheetsAsCsv()
Dim WS As Worksheet
Dim SaveToDirectory As String, newName As String
SaveToDirectory = "H:\test\"
For Each WS In ThisWorkbook.Worksheets
newName = GetBookName(ThisWorkbook.Name) & "_" & WS.Name
WS.Copy
ActiveWorkbook.SaveAs SaveToDirectory & newName, xlCSV
ActiveWorkbook.Close Savechanges:=False
Next
End Sub
Function GetBookName(strwb As String) As String
GetBookName = Left(strwb, (InStrRev(strwb, ".", -1, vbTextCompare) - 1))
End Function
Best way to find out is to record the macro and perform the exact steps and see what VBA code it generates. you can then go and replace the bits you want to make generic (i.e. file names and stuff)
The code above works perfectly with one minor flaw; the resulting file is not saved with a .csv extension. – Tensigh 2 days ago
I added the following to code and it saved my file as a csv. Thanks for this bit of code.It all worked as expected.
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & "-" & WS.Name & ".csv", FileFormat:=xlCSV