I have a workbook with 3 sheets in them, I am using the below macro to export the sheets as .csv files. However sheet1 gets exported with the data in it and sheet2 gets exported without any data in it and is a blank file. The goal is to successfully export Sheet1 and Sheet2 as .csv files with data in them without overwriting the original workbook. Any help would be much appreciated.
Sub Export_Files_Click()
Dim ws As Worksheet
Dim path As String
path = ActiveWorkbook.path & "\" & Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1)
For Each ws In Worksheets
ws.Activate
On Error Resume Next
ActiveWorkbook.SaveAs Filename:=path & "_" & ws.Name & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Next
End Sub
Export Worksheets (to Separate Workbooks)
Consider the active workbook named Test.xlsm containing only worksheets Sheet1 and Sheet2 (tab names).
Then the following, run from this or another workbook, will save the files Test_Sheet1.csv (containing only the worksheet Sheet1) and Test_Sheet2.csv (containing only the worksheet Sheet2) to the active workbook's path (folder).
Standard Module e.g. Module1
Option Explicit
Sub ExportWorksheets()
Dim swb As Workbook: Set swb = ActiveWorkbook
Dim swbPathAndLeftName As String: swbPathAndLeftName _
= swb.path & "\" & Left(swb.Name, InStrRev(swb.Name, ".") - 1) & "_"
Application.ScreenUpdating = False
Dim sws As Worksheet
Dim dwb As Workbook
Dim dFilePath As String
For Each sws In swb.Worksheets
dFilePath = swbPathAndLeftName & sws.Name & ".csv"
sws.Copy ' copies worksheet to a new (one worksheet) workbook...
Set dwb = ActiveWorkbook ' ... which becomes active
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs Filename:=dFilePath, FileFormat:=xlCSV, _
CreateBackup:=False ', Local:=True ' if semicolon instead of comma
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False
Next sws
Application.ScreenUpdating = True
MsgBox "Worksheets exported.", vbInformation, "Export Worksheets"
End Sub
The CommandButton (wherever)
Sub Export_Files_Click()
ExportWorksheets
End Sub
Related
Is there a way to save the active/selected worksheet without having to specify sheets(1)?
The code below is execute via command button and will take the worksheet "Quote" copy to a new workbook, and then prompt to save under the downloads directory.
I'm also trying to get that button to save whichever sheet is selected, it could be Quote or Sheet1, but not both.
Private Sub CommandButton4_Click() ' save worksheet
'Gets the name of the currently visible worksheet
Filename = ActiveSheet.Name
'Puts the worksheet into its own workbook
ThisWorkbook.ActiveSheet.Copy
'Saves the workbook - uses the name of the worksheet as the name of the new workbook
'Filename = Range("A1")
'ActiveWorkbook.Save
Dim NameFile As Variant
With Worksheets("Quote")
'NameFile = .Range("A1") & "_" & .Range("B5") & "_" & ".xls"
End With
NameFile = Application.GetSaveAsFilename(InitialFileName:=Environ("USERPROFILE") & "\Downloads\" & NameFile, Filefilter:="Fichier Excel (*.xls), *.xls")
If NameFile = False Then
MsgBox "File not saved"
Else
ActiveWorkbook.SaveAs Filename:=NameFile
End If
'Closes the newly created workbook so you are still looking at the original workbook
ActiveWorkbook.Close
End Sub
This Sub creates a new Workbook from a sheet. But you must have a way to call this Sub of every sheet, or a better place is a button in the ribbon witch in it's handler: Call NewBookOfSheet(ActiveSheet).
Public Sub NewBookOfSheet(ws As Worksheet)
Dim nwb As Workbook, curwb As Workbook
If ws Is Nothing Then Exit Sub
Set curwb = ws.Parent
Set nwb = Workbooks.Add
curwb.Activate
ws.Select
ws.Copy Before:=nwb.Sheets(1)
nwb.Activate
Application.Dialogs(xlDialogSaveAs).Show ws.Name
End Sub
Copy the Active Worksheet to a New Workbook
Private Sub CommandButton4_Click() ' save worksheet
If ActiveSheet Is Nothing Then Exit Sub ' no visible workbooks open
If Not TypeOf ActiveSheet Is Worksheet Then Exit Sub ' not a worksheet
Dim sws As Worksheet: Set sws = ActiveSheet
sws.Copy
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
Dim dws As Worksheet: Set dws = dwb.Sheets(1) ' the one and only
Dim dwbName: dwbName = Application.GetSaveAsFilename( _
InitialFileName:=Environ("USERPROFILE") & "\Downloads\" & dws.Name, _
FileFilter:="Fichier Excel (*.xls), *.xls")
If dwbName = False Then
MsgBox "File not saved", vbCritical
Else
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs Filename:=dwbName, FileFormat:=xlWorkbookNormal
Application.DisplayAlerts = True
End If
dwb.Close SaveChanges:=False
' Now 'dws' and 'dwb' are invalid but still 'Not Nothing'.
' On the other hand, 'sws' still points to the (initial) source worksheet.
' If you need to reference the source workbook use:
'Dim swb As Workbook: Set swb = sws.Parent
End Sub
I am currently using following code to save an Excel workbook. Instead of saving complete work book, I just wish to save a sheet in this workbook named Reconciliation. All values in the sheet should be saved as values while keeping the formatting the same.
Sub Button3_Click()
' Yes
' Code to save consumer wise mirs on the desktop
Dim Path As String
Dim filename As String
On Error GoTo Err_Clear
Path = Environ("USERPROFILE") & "\Desktop\rohailnisar\"
filename = Range("A1")
ActiveWorkbook.SaveAs filename:=Path & filename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Err_Clear:
If Err <> 0 Then
MkDir CreateObject("wscript.shell").specialfolders("desktop") & "\rohailnisar"
Path = Environ("USERPROFILE") & "\Desktop\rohailnisar\"
filename = Range("A1")
ActiveWorkbook.SaveAs filename:=Path & filename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
End If
End Sub
Export a Worksheet
This saves a copy of a worksheet as the only sheet in a new workbook in the same folder. Before saving, it converts formulas to values. It is saved in the .xlsx format 'removing' any code.
If the code is in the open (initial) workbook, then replace ActiveWorkbook with ThisWorkbook.
Option Explicit
Sub SaveWorksheet()
On Error GoTo ClearError
Dim swb As Workbook: Set swb = ActiveWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("Reconciliation")
Dim FolderPath As String: FolderPath = swb.Path & Application.PathSeparator
Dim BaseName As String: BaseName = sws.Range("E1").Value
Dim FilePath As String: FilePath = FolderPath & BaseName & ".xlsx"
sws.Copy
Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
dwb.Worksheets(1).UsedRange.Value = dwb.Worksheets(1).UsedRange.Value
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
'dwb.Close
ProcExit:
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub
Instead of saving complete work book, I just wish to save a sheet in this workbook named Reconciliation. All values in the sheet should be saved as values while keeping the formatting the same.
Code
Dim wbThis As Workbook
Dim wsThis As Worksheet
Dim wbThat As Workbook
Dim wsThat As Worksheet
'~~> Change this to the workbook which has the Reconciliation sheet
Set wbThis = ThisWorkbook
Set wsThis = wbThis.Sheets("Reconciliation")
'~~> This will create a new workbook with only Reconciliation
wsThis.Copy
'~~> Get that object. It will be last in the queue
Set wbThat = Workbooks(Workbooks.Count)
Set wsThat = wbThat.Sheets("Reconciliation")
'~~> Convert to values
wsThat.UsedRange.Value = wsThat.UsedRange.Value
'~~> Save that workbook
wbThat.SaveAs Filename:=Path & Filename, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Apologies for any bad coding or ignorance I'm a very basic user of VBA.
I have a WorkbookA that has X number of sheets which can change daily. I cobbled together code which will copy the active sheet from WorkbookA to WorkbookB, define a save directory and name, save, and close WorkbookB.
I want to loop through all sheets in WorkbookA starting from the active sheet to the last sheet. How can i go about doing this?
Public Sub CopySheetToNewWorkbook()
ActiveSheet.Copy
Name = ActiveSheet.Name & ".xls"
Path = "MyPath\"
ActiveWorkbook.SaveAs (Path & Name)
ActiveWorkbook.Close
End Sub
Copy Sheets to Separate Workbooks
Use with caution because files will be overwritten without asking.
Option Explicit
Sub CopySheetToNewWorkbook()
Const MyPath As String = "MyPath" ' Sub Folder Name of This Workbook's Path
Dim ws As Worksheet ' First Worksheet
Dim i As Long ' Sheets Counter
Dim SavePath As String ' Save Path
Dim SaveFullName As String ' Save Full Name
With ThisWorkbook
Set ws = .ActiveSheet
SavePath = .Path & Application.PathSeparator & MyPath _
& Application.PathSeparator
Application.ScreenUpdating = False
For i = ws.Index To .Sheets.Count
With .Sheets(i)
SaveFullName = SavePath & .Name & ".xls"
.Copy
End With
GoSub SaveAndClose
Next i
Application.ScreenUpdating = True
End With
MsgBox "Copied sheets to new workbooks.", vbInformation, _
"New Workbooks Saved and Closed"
GoTo exitProcedure
' Save and close new workbook.
SaveAndClose:
On Error GoTo NewWorkbookError ' e.g. if workbook with same name is open.
With ActiveWorkbook
' Note: The two Application.DisplayAlerts lines prevent Excel
' complaining about e.g.:
' Overwrite if file exists.
' Save if data outside of FileFormat (Compatibility Checker).
Application.DisplayAlerts = False
.SaveAs SaveFullName, FileFormat:=xlExcel8
Application.DisplayAlerts = True
.Close False ' Close but do not save.
End With
On Error GoTo 0
Return
NewWorkbookError:
ActiveWorkbook.Close False ' Close but do not save.
MsgBox Err.Description, vbExclamation, "New Workbook Closed and Not Saved"
Resume exitProcedure
exitProcedure:
End Sub
Copy Sheets to Single Workbook
I developed this code first assuming (misreading the post) that the ActiveSheet had some kind of date in its name.
Use with caution because files will be overwritten without asking.
Sub CopySheetsToNewWorkbook()
Const MyPath As String = "MyPath" ' Sub Folder Name of This Workbook's Path
Dim ws As Worksheet ' First Worksheet
Dim SheetsGroup() As String ' Sheets Group Array
Dim SheetsDiff As Long ' Sheets Difference
Dim i As Long ' Sheets Array Elements (Columns) Counter
Dim SavePath As String ' Save Path
Dim SaveName As String ' Save Name
' Copy sheets from this workbook to new workbook.
With ThisWorkbook
' Define First Worksheet, Save Name and Save Path.
Set ws = .ActiveSheet
SaveName = ws.Name & ".xls"
SavePath = .Path & Application.PathSeparator & MyPath _
& Application.PathSeparator & SaveName
' Write sheet names to Sheets Group Array.
ReDim SheetsGroup(.Sheets.Count - ws.Index)
SheetsDiff = .Sheets.Count - ws.Index
For i = 0 To SheetsDiff
SheetsGroup(i) = .Worksheets(i + SheetsDiff - 1).Name
Next i
' Copy sheets from Sheets Group Array to new workbook (ActiveWorkbook).
.Sheets(SheetsGroup).Copy
End With
' Save and close New Workbook.
On Error GoTo NewWorkbookError ' e.g. if workbook with same name is open.
With ActiveWorkbook
' Note: The two Application.DisplayAlerts lines prevent Excel
' from complaining about e.g.:
' Overwrite if file exists.
' Save if data outside of FileFormat (Compatibility Checker).
Application.DisplayAlerts = False
.SaveAs SavePath, FileFormat:=xlExcel8
Application.DisplayAlerts = True
.Close False ' Close but do not save.
End With
On Error GoTo 0
MsgBox "Copied sheets to new workbook.", vbInformation, _
"New Workbook Saved and Closed"
GoTo exitProcedure
NewWorkbookError:
ActiveWorkbook.Close False ' Close but do not save.
MsgBox Err.Description, vbExclamation, "New Workbook Closed and Not Saved"
Resume exitProcedure
exitProcedure:
End Sub
Close Workbooks
A few times I had over ten workbooks open while developing the previous code, so I wrote this little time saver.
Use it with caution because workbooks will be closed without saving changes.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Closes all workbooks except this one (ThisWorkbook). '
' Remarks: Be careful because all the changes on those other workbooks '
' will be lost. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub closeWorkbooks()
Dim wb As Workbook
Application.ScreenUpdating = False
For Each wb In Workbooks
If Not wb Is ThisWorkbook Then wb.Close False
Next wb
Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
I want to copy multiple sheets from one workbook(4 out of 14) but i'm starting with one("Data"). I want to rename the workbook based on a cell in the first workbook. with this code I get an "run-time error '1004' Excel cannot access the file 'C:\3B4DD....
my code so far:
Sub Newyeartest()
sheetstocopy = "data"
Worksheets(sheetstocopy).Copy
Dim FName As String
Dim FPath As String
FPath = "C:"
FName = Sheets("data").Range("A1") & ".xlsm"
ThisWorkbook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52
End sub
If I delete the "Fileformat:=52" It seems to go better but I get a text that this file must be saved as an macro enabled file. But I would guess that "Xlsm" is macro enabled?
Instead of copying worksheets, the better way is to copy the workbook with all the worksheets and then delete the ones that are not needed.
The code saves the workbook first, using the path of the current workbook;
Then it starts checking every worksheet, making sure that the name is not "data";
If the name is not "data" and there are more than 1 worksheets left, it deletes the worksheet;
The Application.DisplayAlerts = False is needed, in order to remove the msgbox for confirmation of the deletion of the worksheet. Then the Alerts are back set to True;
If the name is not "data" and this is the last worksheet, it gives a MsgBox "Last worksheet cannot be deleted!", as far as a workbook should always have at least 1 worksheet, by design;
Sub NewTest()
ThisWorkbook.SaveAs ThisWorkbook.Path & "\new.xlsm"
Dim sheetToCopy As String: sheetToCopy = "data"
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If wks.Name <> sheetToCopy Then
If ThisWorkbook.Worksheets.Count > 1 Then
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(wks.Name).Delete
Application.DisplayAlerts = True
Else
MsgBox "Last worksheet cannot be deleted!"
End If
End If
Next wks
End Sub
This should do the trick:
Option Explicit
Sub Newyeartest()
Dim wb As Workbook
Dim SheetNames As Variant, Key As Variant
Dim FName As String, FPath As String
Application.ScreenUpdating = False
SheetNames = Array("data", "data2", "data3", "data4") 'store the sheet names you want to copy
Set wb = Workbooks.Add 'set a workbook variable which will create a new workbook
'loop through the sheets you previously stored to copy them
For Each Key In SheetNames
ThisWorkbook.Sheets(Key).Copy After:=wb.Sheets(wb.Sheets.Count)
Next Key
'delete the first sheet on the new created workbook
Application.DisplayAlerts = False
wb.Sheets(1).Delete
FPath = "C:\Test"
FName = ThisWorkbook.Sheets("data").Range("A1") & ".xlsm"
wb.SaveAs Filename:=FPath & "\" & FName, FileFormat:=52
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
You cannot save directly to C:\ so you need to create a folder and the code will work.
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