The code below creates and saves all the excel sheets from "Test_Main" into separate new workbooks with file extension .xlsx and I want it to save the workbook in .csv format. Could someone please alter my current code to do the required job ? Thanks in advance :)
Sub Workbook()
Dim a As Integer
Dim ws As Worksheet
Dim wb As Workbook
a = ThisWorkbook.Worksheets.Count 'counts all the sheets
For i = 1 To a 'loops for all sheets
If ThisWorkbook.Worksheets(i).Name <> "Test_Main" Then 'rule out the main sheet
Set wb = Workbooks.Add
ThisWorkbook.Worksheets(i).Copy before:=wb.Worksheets(1) 'new workbook has 1 worksheet by deafult
wb.SaveAs "H:\IT\Melissa\Essengeld\TEST\" & ThisWorkbook.Worksheets(i).Name
wb.Close savechages = True
End If
Next i
ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Activate
ThisWorkbook.Sheets(1).Cells(1, 1).Select
MsgBox ("Task Completed")
End Sub
Microsoft answer question here -> https://learn.microsoft.com/en-us/office/vba/api/excel.workbook.saveas
I took code from to export a sheet from here
Sub exportSheet(sh As Worksheet, csvFilename As String)
Dim wbNew As Workbook
Set wbNew = Workbooks.Add
Dim wsNew As Worksheet
With wbNew
sh.Copy wbNew.Sheets(1)
Set wsNew = wbNew.Sheets(1)
.SaveAs Filename:=csvFilename, _
FileFormat:=xlCSVMSDOS, CreateBackup:=False
.Close False
End With
End Sub
and used it in your code like that
Sub exportToCSV()
Dim a As Integer
Dim ws As Worksheet
Dim wb As Workbook
a = ThisWorkbook.Worksheets.Count 'counts all the sheets
For i = 1 To a 'loops for all sheets
If ThisWorkbook.Worksheets(i).Name <> "Test_Main" Then 'rule out the main sheet
' Set wb = Workbooks.Add
' ThisWorkbook.Worksheets(i).Copy before:=wb.Worksheets(1) 'new workbook has 1 worksheet by deafult
' wb.SaveAs "H:\IT\Melissa\Essengeld\TEST\" & ThisWorkbook.Worksheets(i).Name
'
' wb.Close savechages = True
exportSheet ThisWorkbook.Worksheets(i), "H:\IT\Melissa\Essengeld\TEST\" & ThisWorkbook.Worksheets(i).Name
End If
Next i
ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Activate
ThisWorkbook.Sheets(1).Cells(1, 1).Select
MsgBox ("Task Completed")
End Sub
I found the solution:
wb.SaveAs "H:\IT\Melissa\Essengeld\TEST" & ThisWorkbook.Worksheets(i).Name , FileFormat:=xlCSV
Related
I have a macro that works
Sub EXPORT_POR()
Dim wb As Workbook
Dim ws As Worksheet
Dim FileSaveName As Variant
FileSaveName = Application.GetSaveAsFilename(fileFilter:="Text (Tab delimited) (*.*), *.*")
Sheets("POR_FINAL_OU").Copy
Set wb = ActiveWorkbook
Set ws = ActiveSheet
With wb
With ws
.Range("A:C").SpecialCells(xlCellTypeBlanks).EntireRow.DELETE
.Range(.Cells(1, "C"), .Cells(.Rows.Count, .Columns.Count)).Clear
End With
.SaveAs FileSaveName, xlTextWindows
.Close False
End With
i = MsgBox("Soubor uložen", vbOKOnly + vbInformation)
End Sub
Now I have extended the sheet with additional columns and thus logically extended the code
Sub EXPORT_POR()
Dim wb As Workbook
Dim ws As Worksheet
Dim FileSaveName As Variant
FileSaveName = Application.GetSaveAsFilename(fileFilter:="Text (Tab delimited) (*.*), *.*")
Sheets("POR_FINAL_OU").Copy
Set wb = ActiveWorkbook
Set ws = ActiveSheet
With wb
With ws
.Range("A:G").SpecialCells(xlCellTypeBlanks).EntireRow.DELETE
.Range(.Cells(1, "G"), .Cells(.Rows.Count, .Columns.Count)).Clear
End With
.SaveAs FileSaveName, xlTextWindows
.Close False
End With
i = MsgBox("Soubor uložen", vbOKOnly + vbInformation)
End Sub
Now I get the following error when I start macro
"error 1004 - Cannot use that command on overlapping selections"
I have no idea how to fix it
i solved this way. Juste change this:
With ws
.Range("G:G").SpecialCells(xlCellTypeBlanks).EntireRow.DELETE
.Range(.Cells(1, "G"), .Cells(.Rows.Count, .Columns.Count)).Clear
End With
.SaveAs FileSaveName, xlTextWindows
.Close False
I want to create a new (separate) workbooks for each worksheets from Test_Main but I am getting a
1004 error
in this line of code stating that I need a new name and cannot use this name as it is in use.
wb.SaveAs "H:\IT\Melissa\Essengeld\TEST" & "\" & ActiveSheet.Name & ".csv"
Is my code right? Or is there any other alternative for this ?
Thanks in advance !
Private Sub CommandButton3_Click()
Dim a As Integer
Dim ws As Worksheet
Dim wb As Workbook
a = ThisWorkbook.Worksheets.Count 'counts all the sheets
For i = 1 To a 'loops for all sheets
If ThisWorkbook.Worksheets(i).Name <> "Test_Main" Then 'rule out the main sheet
Set wb = Workbooks.Add
ThisWorkbook.Worksheets(i).Copy before:=wb.Worksheets(1) 'new workbook has 1 worksheet by deafult
wb.SaveAs "H:\IT\Melissa\Essengeld\TEST" & "\" & ActiveSheet.Name & ".csv"
wb.Close savechages = True
End If
Next i
ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Activate
ThisWorkbook.Sheets(1).Cells(1, 1).Select
MsgBox ("Task Completed")
End Sub
Hey I am quite new to VBA and I am currently trying to export tables from different sheets, if there is an alternation made to it, as CSV data. Currently my code exports all tables from my file. How can I make it export only the current table that I am executing the makro on?
Thank you for your help!
Public Sub SaveWorksheetsAsCsv()
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.SaveAs xDir & "\" & xWs.name, xlCSV
Next
End Sub
I figured out a way to do it but now the window opens as a CSV file. How do i close the csv file and reopen the worksheet I was working on?
Public Sub SaveWorksheetsAsCsvUndercarriageDefinition()
Dim wbk As Workbook
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Set wbk = Workbooks("Vba_Fehlerprüfung.xlsm")
Set xWs = wbk.Worksheets("Undercarriage Definition")
Set folder =
Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
'For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.SaveAs xDir & "\" & xWs.name, xlCSV
'Next
End Sub
My suggestion would be to use the following sub in order to export a table resp. an listobject
Sub exportListobject(lo As ListObject, csvFilename As String)
Dim wbNew As Workbook
Set wbNew = Workbooks.Add
Dim wsNew As Worksheet
With wbNew
Set wsNew = wbNew.Sheets(1)
lo.Range.Copy
wsNew.Range("A1").PasteSpecial Paste:=xlPasteAll
.SaveAs Filename:=csvFilename, _
FileFormat:=xlCSVMSDOS, CreateBackup:=False
.Close False
End With
End Sub
It will copy the listobject in question into a new workbook, save it as an csv file and close it. The workbook which contains the listobject will not be touched.
If you want to export a single sheet from your workbook you can use a similar sub
Sub exportSheet(sh As Worksheet, csvFilename As String)
Dim wbNew As Workbook
Set wbNew = Workbooks.Add
Dim wsNew As Worksheet
With wbNew
sh.Copy wbNew.Sheets(1)
Set wsNew = wbNew.Sheets(1)
.SaveAs Filename:=csvFilename, _
FileFormat:=xlCSVMSDOS, CreateBackup:=False
.Close False
End With
End Sub
I have several sheets I need to copy to a new workbook and then save this workbook.
I'm using the worksheet function to copy which it seems to me like it's the intended purpose of that function.
Here's the MSDN documentation on how to do this task:
Worksheets("Sheet1").Copy
With ActiveWorkbook
.SaveAs Filename:=Environ("TEMP") & "\New1.xlsx", FileFormat:=xlOpenXMLWorkbook
.Close SaveChanges:=False
End With
https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.copy
This is doing exactly what I want, but it's using the ActiveWorkbook property which might cause some error, if running other codes or just working in parallel of this code running.
I'm looking for a way to manipulate the newly created workbook without having to use the ActiveWorkbook property.
Something along the lines of this:
Dim wb as Workbook
set wb = Worksheets("Sheet1").Copy
wb.SaveAs Filename:=Environ("TEMP") & "\New1.xlsx", FileFormat:=xlOpenXMLWorkbook
wb.Close SaveChanges:=False
I've already tried this and it didn't work, but it's just to illustrate the point that it's not using the ActiveWorkbook property to refer to the new workbook.
Thanks in advance
From above comment:
Sub Tester()
With AsNewWorkbook(Sheet1)
Debug.Print .Name
.SaveAs "C:\Temp\blah.xlsx"
End With
End Sub
Function AsNewWorkbook(ws As Worksheet)
Dim wb As Workbook
Set wb = Workbooks.Add(xlWBATWorksheet) 'has one sheet...
With wb.Sheets(1) 'stolen from Cristian's answer...
If .Name = ws.Name Then .Name = .Name & "x"
End With
ws.Copy before:=wb.Worksheets(1)
Application.DisplayAlerts = False
wb.Worksheets(2).Delete
Application.DisplayAlerts = True
Set AsNewWorkbook = wb
End Function
#BigBen is right though - typically just using ActiveWorkbook is fine.
An improvement on #TimWilliams response so that you can copy multiple sheets at once:
Sub Test()
Dim sourceBook As Workbook
'
Set sourceBook = ThisWorkbook 'Or ActiveWorkbook or whatever book is needed
With CopySheetsToNewBook(sourceBook.Sheets(Array("Sheet1", "Sheet2")))
.SaveAs Filename:=Environ("TEMP") & "\New1.xlsx", FileFormat:=xlOpenXMLWorkbook
End With
sourceBook.Close SaveChanges:=False
End Sub
Public Function CopySheetsToNewBook(ByVal theSheets As Sheets) As Workbook
If theSheets Is Nothing Then
Err.Raise 91, "CopySheetsToNewBook", "Sheets not set"
End If
'
Dim newBook As Workbook
Dim tempSheet As Worksheet
'
Set newBook = Application.Workbooks.Add(xlWBATWorksheet)
Set tempSheet = newBook.Worksheets(1) 'To be deleted later
tempSheet.Name = CDbl(Now) 'Avoid name clashes with the sheets to be copied
'
theSheets.Copy Before:=tempSheet
Application.DisplayAlerts = False
tempSheet.Delete
Application.DisplayAlerts = True
'
Set CopySheetsToNewBook = newBook
End Function
Copy Worksheet(s) to a New Workbook
Sub NewWorkbook()
' Reference the source workbook.
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
swb.Worksheets("Sheet1").Copy ' copy one worksheet to a new workbook
'swb.Worksheets(Array("Sheet1", "Sheet2")).Copy ' copy multiple worksheets
' Reference the destination (new) workbook.
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
Debug.Print swb.Name, dwb.Name
End Sub
I have workbook and there many sheets i want to copy one by one sheets to new work book and rename workbook
I tried, but it saved in one workbook instead of separate workbooks also I don't want to copy first worksheet to copy new workbook
Option Explicit
Sub CreateWorkBooks()
Dim ws As Object
Dim i As Long
Dim ws_num As Integer
Application.ScreenUpdating = False
Set ws = Worksheets
ws_num = ThisWorkbook.Worksheets.Count
For i = 2 To ws_num
'Copy one worksheet as a new workbook
'The new workbook becomes the ActiveWorkbook
ws.Copy
'Replace all formulas with values (optional)
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
'May want (not required) to add a file name extension (.xls or .xlsx) to the file name
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & _
"AR Balance- " & ActiveSheet.Name & " " & Worksheets("DATA Sheet").Range("m2") & ".xlsx"
ActiveWorkbook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
End Sub
Welcome to SO. Only simple self explanatory corrections made. Try
Option Explicit
Sub CreateWorkBooks()
Dim ws As Worksheet ' Worksheets instead of Object
Dim i As Long
Dim ws_num As Integer
'Application.ScreenUpdating = False
ws_num = ThisWorkbook.Worksheets.Count
For i = 2 To ws_num
Set ws = ThisWorkbook.Worksheets(i) 'set ws to each sheet in the workbook
'Copy one worksheet as a new workbook
'The new workbook becomes the ActiveWorkbook
ws.Copy
'Replace all formulas with values (optional)
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
'May want (not required) to add a file name extension (.xls or .xlsx) to the file name
' Thisworkbook is to be added to refer Worksheets("DATA Sheet").Range("m2").Value
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & _
"AR Balance- " & ActiveSheet.Name & " " & ThisWorkbook.Worksheets("DATA Sheet").Range("m2").Value & ".xlsx"
ActiveWorkbook.Close False
Next
'Application.ScreenUpdating = True
End Sub