I am using the following VBA to save specific sheets. I would like to save the sheets at HTML. I tried changing the . xls to .html but all I get is gobby gook (technical term) Any help would be appreciated.
Option Explicit
Sub TwoSheetsAndYourOut()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
With Application
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, separated by commas
On Error GoTo ErrCatcher
Sheets(Array("Copy Me", "Copy Me2")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
Use Ron de Bruin's RangetoHTML code. Call it from within your For Each ws... loop
I found the solution,
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.SaveAs Filename:="C:**locationtosave**.html", FileFormat:=xlHtml
Related
I am new to excel VBA. I have already written VBA code to select any Excel file and copy path of that file to cell A1. Using the path I am trying to copy contents of source file, Sheet7, while retaining cell formatting i.e. bold, borders, colors, etc.
My first error is appearing for file path. Currently cell A1 value = C:\Users\Personal\Documents\Excel files\Dummy-Data - Copy.xlsx.
When I try to read value of A1 cell, VBA throws me an error "Sorry, we couldn't find. Is it possible it was moved, renamed or deleted?" and automatically clears the value of cell A1. But when I give the same path directly in VBA script, it works! Can someone tell me how to get this fixed?
My second doubt is around copying cell formats. When I use wksht.paste to paste copied content to Sheet2, it just pastes all cell values without formatting. But when I try to use PasteSpecial following error occurs- "Application-defined or object-defined error" . Can someone help me correct this please?
Sub Button1_Click()
' define variables
Dim lastRow As Long
Dim myApp As Excel.Application
Dim wbk As Workbook
Dim wkSht As Object
Dim filePath As Variant
'on error statement
On Error GoTo errHandler:
' Select file path
Set myApp = CreateObject("Excel.application")
Sheet2.Range("A1").Value = filePath
Set wbk = myApp.Workbooks.Open(filePath)
'Set wbk = myApp.Workbooks.Open("C:\Users\Personal\Documents\Excel files\Dummy-Data - Copy.xlsx")
' Copy contents
Application.ScreenUpdating = False
lastRow = wbk.Sheets(7).Range("A" & Rows.Count).End(xlUp).Row
wbk.Sheets(7).Range("A2:Q" & lastRow).Copy
myApp.DisplayAlerts = False
wbk.Close
myApp.Quit
' Paste contents
Set wbk = Nothing
Set myApp = Nothing
Set wbk = ActiveWorkbook
Set wkSht = wbk.Sheets("Sheet2")
wkSht.Activate
Range("A2").Select
wkSht.Paste
'wkSht.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.ScreenUpdating = True
Exit Sub
'error block
errHandler:
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please follow instruction sheet"
End Sub
My first error is appearing for file path. Currently cell A1 value = C:\Users\Personal\Documents\Excel files\Dummy-Data - Copy.xlsx. When I try to read value of A1 cell, VBA throws me an error "Sorry, we couldn't find. Is it possible it was moved, renamed or deleted?" and automatically clears the value of cell A1.
You're not setting a var's value to the value of a cell, you're setting the cell's value to a blank var thereby erasing the cell's value. It should be filePath = Sheet2.Range("A1").Value, (the reverse of what you have above).
When I use wksht.paste to paste copied content to Sheet2, it just pastes all cell values without formatting.
You're not just pasting between workbooks; you're pasting between workbooks open in separate application instances. You lose detail like formatting when pasting across instances. In any event, the separate Excel.Application seems wholly unnecessary.
Option Explicit
Sub Button1_Click()
' define variables
Dim lastRow As Long
Dim wbk As Workbook
Dim filePath As Variant
'on error statement
On Error GoTo errHandler:
' Select file path
filePath = Sheet2.Range("A1").Value
Set wbk = Workbooks.Open(filePath)
'Set wbk = Workbooks.Open("C:\Users\Personal\Documents\Excel files\Dummy-Data - Copy.xlsx")
' Copy contents & Paste contents
Application.ScreenUpdating = False
lastRow = wbk.Sheets(7).Range("A" & Rows.Count).End(xlUp).Row
wbk.Sheets(7).Range("A2:Q" & lastRow).Copy _
Destination:=Sheet2.Range("A2")
'shouldn't have to disable alerts
'Application.DisplayAlerts = False
wbk.Close savechanges:=False
'Application.DisplayAlerts = True
'
Application.ScreenUpdating = True
Exit Sub
'error block
errHandler:
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please follow instruction sheet"
End Sub
The naked worksheet codename references should be valid within ThisWorkbook.
I am not able to copy data from one workbook to another. But with in same workbook its working. After running the macro program the destination worksheet is empty. I have 2 codes. Both are not working. My source file is .xlsx format and destination file is .xlsm format. Is there any mistakes?
Code1:
Sub mycode()
Workbooks.Open Filename:="source_file"
Worksheets("Sheet1").Cells.Select
Selection.Copy
Workbooks.Open Filename:="destination_file"
Worksheets("Sheet1").Cells.Select
Selection.PasteSpecial
ActiveWorkbook.Save
End Sub
Code 2
Sub foo2()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("source file")
Set y = Workbooks.Open("destination file")
y.Sheets("Sheet1").Range("A1").Value = x.Sheets("Sheet1").Range("A1")
x.Close
End Sub
I assume that you are writing below Code1 and Code2 excel macros in a separate file, say copy_paste.xlsm:
Code 1 is working when you provide a full path of files to Workbooks.open:
Sub mycode()
Workbooks.Open Filename:="C:\Users\xyz\Documents\Excel-Problem\source_file.xlsx"
Worksheets("Sheet1").Cells.Select
Selection.Copy
Workbooks.Open Filename:="C:\Users\xyz\Documents\Excel-Problem\destination_file.xlsm"
Worksheets("Sheet1").Cells.Select
Selection.PasteSpecial xlPasteValues 'xlPasteAll to paste everything
ActiveWorkbook.Save
ActiveWorkbook.Close SaveChanges:=True 'to close the file
Workbooks("source_file").Close SaveChanges:=False 'to close the file
End Sub
To paste everything (formulas + values + formats), use paste type as xlPasteAll.
Code 2 is working too, all you need is to provide full path and you are missing _ in file names:
Sub foo2()
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("C:\Users\xyz\Documents\Excel-Problem\source_file.xlsx")
Set y = Workbooks.Open("C:\Users\xyz\Documents\Excel-Problem\destination_file.xlsm")
'it copies only Range("A1") i.e. single cell
y.Sheets("Sheet1").Range("A1").Value = x.Sheets("Sheet1").Range("A1")
x.Close SaveChanges:=False
y.Close SaveChanges:=True
End Sub
edited to add a (minimum) file check
you must specify full file path, name and extension
more over you can open only destination file, like this
Option Explicit
Sub foo2()
Dim y As Workbook
Dim sourcePath As String, sourceFile As String, destFullPath As String '<--| not necessary, but useful not to clutter statements
sourcePath = "C:\Users\xyz\Documents\Excel-Problem\" '<--| specify your source file path down to the last backslash and with no source file name
sourceFile = "source_file.xlsx" '<--| specify your source file name only, with its extension
destFullPath = "C:\Users\xyz\Documents\Excel-Problem\destination_file.xlsm" '<--| specify your destination file FULL path
If Dir(destFullPath) = "" Then '<--| check is such a file actually exists
MsgBox "File " & vbCrLf & vbCrLf & destFullPath & vbCrLf & vbCrLf & "is not there!" & vbCrLf & vbCrLf & vbCrLf & "The macro stops!", vbCritical
Else
Set y = Workbooks.Open(destFullPath)
With y.Sheets("Sheet1").Range("A1")
.Formula = "='" & sourcePath & "[" & sourceFile & "]Sheet1'!$A$1"
.Value = .Value
End With
y.Close SaveChanges:=True
End If
End Sub
you could even open neither of them using Excel4macro
Hello thanks for reading my question, I have a Workbook with hidden templates and most of them are used as Excel .xlsx spreadsheet however one of them requires a module to be inserted for it to work. I thought simple enough just add a param to my function that creates the workbook.
It doesn't seem to work because i get an error "Error Number 1004 This extension can not be used with the selected file type. Change the file extension in the file name text box or select a different file type blabla"
Public Function gWrkBook(template As String, Optional wbMacro As Boolean) As Workbook
Dim wbNew As Workbook
Dim wsTemplate As Worksheet, wsSummary As Worksheet
Set wsTemplate = ThisWorkbook.Worksheets(template) '===== Create new workbook and copy template
wsTemplate.Visible = True
'
Set wbNew = Workbooks.Add 'Create New file
wsTemplate.Copy Before:=wbNew.Sheets(1) 'Copy template to new workbook
'Rename sheet
On Error GoTo ErrSheetName
wbNew.Sheets(1).Name = "SUMMARY"
Set wsSummary = wbNew.Sheets("SUMMARY")
wsTemplate.Visible = False '===== Clean up
Call gRemoveUnwanted("sheets", wbNew) 'Mod7 '==== Get SaveAs filename and save file
If wbMacro = True Then
vFileName = Application.GetSaveAsFilename(Filname, "Excel Macro-Enabled workbook(*.xlsm), *.xlsm", Title:="SaveAs Workbook Macro-Enabled")
Else
vFileName = Application.GetSaveAsFilename(FileFilter:="Microsoft Excel Workbooks, *.xlsx", Title:="SaveAs Workbook")
End If
On Error GoTo ErrFileName
wbNew.SaveAs Filename:=vFileName
Set gWrkBook = wbNew 'must assign it this way?? not sure why R2
Exit Function
ErrSheetName:
NewSheetName = InputBox("Worksheet exists, try a different name." & vbCrLf & "Enter Sheet Name.")
Resume
ErrFileName:
MsgBox "Error Number " & _
Err.Number & vbCrLf & _
Error(Err) & vbCrLf & _
"Try Again!", _
vbExclamation + vbOKOnly, _
"ERROR!"
vFileName = Application.GetSaveAsFilename(FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", _
Title:="SaveAs Workbook")
Resume
End Function
Try:
wbNew.SaveAs(Filename:=vFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled)
For more information, please read documentation:
VBA SaveAs
VBA File Format XlFileFormat Enumeration.
i have a workbook that i use as a template to make estimates that when i'm done filling out the template there is a macro that creates a new workbook and copies all the sheets of the template workbook to the new one and then removes all the formulas and info i don't want the customer to see.
Here's part of my code that creates the new workbook and copies all the sheets from the template to the new one and then cleans it up
Sub TestConvert()
'Disabling the following to speed up the vba code, must re-enable at end of code
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'adds file name and path to all sheets
Dim WSfn As Worksheet
For Each WSfn In ThisWorkbook.Sheets
'Adds formula to show file path
WSfn.Range("A2") = "=LEFT(CELL(""filename"",RC),FIND(""["",CELL(""filename"",RC),1)-1)"
'Adds formula to show file name
WSfn.Range("A3") = "=MID(CELL(""filename""),FIND(""["",CELL(""filename""))+1,(FIND(""]"",CELL(""filename""))-FIND(""["",CELL(""Filename""))-16))"
WSfn.Calculate 'Calculate sheet
WSfn.Range("A2") = WSfn.Range("A2") 'this will remove the formula from the cell making it text only
WSfn.Range("A3") = WSfn.Range("A3") 'this will remove the formula from the cell making it text only
Next
'************************************************************************************************
'copies all the sheets of the open workbook to a new one
Dim thisWb As Workbook, wbTemp As Workbook
Dim ws As Worksheet
Set thisWb = ThisWorkbook
Set wbTemp = Workbooks.Add 'creates new workbook dimmed as WbTemp
On Error Resume Next 'if there is in error when deleting will not stop the macro from continuing...
'.. deletes the extra sheets 2 sheets if on an older versions of excel
For Each ws In wbTemp.Worksheets
ws.Delete 'deletes all but one sheet in new workbook
Next
On Error GoTo -1 'clears the error handling and sets it to nothing which allows you to create another error trap.
'copys all the sheets from the original to the new workbook dimmed as wbTemp
For Each ws In thisWb.Sheets
ws.Copy After:=wbTemp.Sheets(wbTemp.Worksheets.Count)
Next
wbTemp.Sheets(1).Delete 'deletes the the first sheet in the list in the new workbook which is a black sheet from creating a new workbook
'put vba code to be ran in new book here
'makes all formulas in new workbook values only
wbTemp.Sheets.Select 'selects all sheets in new workbook
Cells.Select 'selects all cell
Selection.Copy 'copies everything selected
Selection.PasteSpecial Paste:=xlPasteValues 'pastes as values only in selected cells
wbTemp.Application.CutCopyMode = False 'clears the clipbored
'removes all defind names from new workbook / submittal
Dim xName As Name
For Each xName In wbTemp.Names
xName.Delete
Next
'removes all dropdowns from new workbook / submittal
Dim DD As Worksheet
For Each DD In wbTemp.Worksheets
Cells.Select
DD.Cells.Validation.Delete
Range("A1").Select
Next
'removes all vba buttons from all sheets
Dim i As Integer
On Error Resume Next
For i = 1 To 1000
wbTemp.Sheets(i).Buttons.Delete
Next i
'All sheets scroll to top left and select "A1"
Dim Sht As Worksheet
'****************************
'change A1 to suit your preference
Const TopLeft As String = "A1"
'****************************
'loop thru all the sheets in the workbook
For Each Sht In Worksheets
'scroll:=True takes cell to the top-left of window
Application.Goto Sheet.Range(TopLeft), scroll:=True
Next
'Hides the following from all sheets
wbTemp.Sheets.Select 'selects all sheets in new workbook
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
'selects the first sheet in the list
Sheets(1).Select
ActiveSheet.DisplayPageBreaks = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'save vba code here
'works to only add the filename would like it to also open in file path from cell A2
Application.Dialogs(xlDialogSaveAs).Show Range("A3").Text & "- (Submittal) " & Format(Date, "mm-dd-yy") & "_" & Format(Time, "hhmm") & ".xlsx"
End Sub
im wanting to make it so when the save window opens it opens in the file path from cell A2 and populates the filename from cell A3
i can also send/post the full excel file if that helps any.
The Application.GetSaveAsFilename method is a good choice for this. Pass the return value to a variant type var so you can test for Cancel or Close.
Dim sFN As Variant
With Worksheets("Sheet6")
sFN = .Range("A1") & Chr(92) & .Range("A2") & Format(Date, "_mm-dd-yy") '<~~ no extension yet
End With
With Application
sFN = .GetSaveAsFilename(InitialFileName:=sFN, _
FileFilter:="Excel Workbook (*.xlsx), *.xlsx," & _
"Macro Workbook (*.xlsm), *.xlsm," & _
"Binary Workbook (*.xlsb), *.xlsb")
End With
Select Case sFN
Case False
'user clicked Cancel or Close (×)
Debug.Print sFN
Case Else
With ThisWorkbook
Select Case Right(sFN, 5)
Case ".xlsx"
.SaveAs Filename:=sFN, FileFormat:=xlOpenXMLWorkbook
Case ".xlsm"
.SaveAs Filename:=sFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Case ".xlsb"
.SaveAs Filename:=sFN, FileFormat:=xlExcel12
Case Else
'there really shouldn't be a case else
End Select
End With
End Select
I've added a Select Case statement statement for a Workbook.SaveAs method to three msot common types of Excel workbooks.
You can use the .InitialFileName property of the dialog.
Dim ws As Excel.Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")
Dim oFileDialog As FileDialog
Set oFileDialog = Application.FileDialog(msoFileDialogSaveAs)
With oFileDialog
.Title = "Save File"
.ButtonName = "Ok"
.InitialFileName = ws.Range("A2").Value & "\" & ws.Range("A3").Value
.Show
End With
If you need to get back the name that it was saved as you can use .SelectedItems after .Show
MsgBox (oFileDialog.SelectedItems(1))
NOTE:
You probably want to do a quick verification that the directory in A2 exists before doing this. If it does not exist it will throw this into some users folder.
EDIT I'm not sure why yours isn't saving, could be excel version or some other variable in your code.
Since you have the path and name, do you really need the saveas dialog? You could just do
Workbooks.Add
'Then your code in your template that is modifying the active workbook
'Then save it without the dialog
ActiveWorkbook.SaveAs ws.Range("A2").Value & "\" & ws.Range("A3").Value
'OR
ActiveWorkbook.SaveAs Filename:= ws.Range("A2").Value & "\" & ws.Range("A3").Value
I have 1 WorkBook("SOURCE") that contains around 20 Sheets.
I want to copy only 1 particular sheet to another Workbook("TARGET") using Excel VBA.
Please note that the "TARGET" Workbook doen't exist yet. It should be created at runtime.
Methods Used -
1) Activeworkbook.SaveAs <--- Doesn't work. This will copy all the sheets. I want only specific sheet.
I have 1 WorkBook("SOURCE") that contains around 20 Sheets. I want to copy only 1 particular sheet to another Workbook("TARGET") using Excel VBA. Please note that the "TARGET" Workbook doen't exist yet. It should be created at runtime.
Another Way
Sub Sample()
'~~> Change Sheet1 to the relevant sheet
'~~> This will create a new workbook with the relevant sheet
ThisWorkbook.Sheets("Sheet1").Copy
'~~> Save the new workbook
ActiveWorkbook.SaveAs "C:\Target.xlsx", FileFormat:=51
End Sub
This will automatically create a new workbook called Target.xlsx with the relevant sheet
To copy a sheet to a workbook called TARGET:
Sheets("xyz").Copy After:=Workbooks("TARGET.xlsx").Sheets("abc")
This will put the copied sheet xyz in the TARGET workbook after the sheet abc
Obviously if you want to put the sheet in the TARGET workbook before a sheet, replace Before for After in the code.
To create a workbook called TARGET you would first need to add a new workbook and then save it to define the filename:
Application.Workbooks.Add (xlWBATWorksheet)
ActiveWorkbook.SaveAs ("TARGET")
However this may not be ideal for you as it will save the workbook in a default location e.g. My Documents.
Hopefully this will give you something to go on though.
You can try this VBA program
Option Explicit
Sub CopyWorksheetsFomTemplate()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
With Application
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
Sheets(Array("Sheet1", "Sheet2")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
The much longer example below combines some of the useful snippets above:
You can specify any number of sheets you want to copy across
You can copy entire sheets, i.e. like dragging the tab across, or you can copy over the contents of cells as values-only but preserving formatting.
It could still do with a lot of work to make it better (better error-handling, general cleaning up), but it hopefully provides a good start.
Note that not all formatting is carried across because the new sheet uses its own theme's fonts and colours. I can't work out how to copy those across when pasting as values only.
Option Explicit
Sub copyDataToNewFile()
Application.ScreenUpdating = False
' Allow different ways of copying data:
' sheet = copy the entire sheet
' valuesWithFormatting = create a new sheet with the same name as the
' original, copy values from the cells only, then
' apply original formatting. Formatting is only as
' good as the Paste Special > Formats command - theme
' colours and fonts are not preserved.
Dim copyMethod As String
copyMethod = "valuesWithFormatting"
Dim newFilename As String ' Name (+optionally path) of new file
Dim themeTempFilePath As String ' To temporarily save the source file's theme
Dim sourceWorkbook As Workbook ' This file
Set sourceWorkbook = ThisWorkbook
Dim newWorkbook As Workbook ' New file
Dim sht As Worksheet ' To iterate through sheets later on.
Dim sheetFriendlyName As String ' To store friendly sheet name
Dim sheetCount As Long ' To avoid having to count multiple times
' Sheets to copy over, using internal code names as more reliable.
Dim colSheetObjectsToCopy As New Collection
colSheetObjectsToCopy.Add Sheet1
colSheetObjectsToCopy.Add Sheet2
' Get filename of new file from user.
Do
newFilename = InputBox("Please Specify the name of your new workbook." & vbCr & vbCr & "Either enter a full path or just a filename, in which case the file will be saved in the same location (" & sourceWorkbook.Path & "). Don't use the name of a workbook that is already open, otherwise this script will break.", "New Copy")
If newFilename = "" Then MsgBox "You must enter something.", vbExclamation, "Filename needed"
Loop Until newFilename > ""
' If they didn't supply a path, assume same location as the source workbook.
' Not perfect - simply assumes a path has been supplied if a path separator
' exists somewhere. Could still be a badly-formed path. And, no check is done
' to see if the path actually exists.
If InStr(1, newFilename, Application.PathSeparator, vbTextCompare) = 0 Then
newFilename = sourceWorkbook.Path & Application.PathSeparator & newFilename
End If
' Create a new workbook and save as the user requested.
' NB This fails if the filename is the same as a workbook that's
' already open - it should check for this.
Set newWorkbook = Application.Workbooks.Add(xlWBATWorksheet)
newWorkbook.SaveAs Filename:=newFilename, _
FileFormat:=xlWorkbookDefault
' Theme fonts and colours don't get copied over with most paste-special operations.
' This saves the theme of the source workbook and then loads it into the new workbook.
' BUG: Doesn't work!
'themeTempFilePath = Environ("temp") & Application.PathSeparator & sourceWorkbook.Name & " - Theme.xml"
'sourceWorkbook.Theme.ThemeFontScheme.Save themeTempFilePath
'sourceWorkbook.Theme.ThemeColorScheme.Save themeTempFilePath
'newWorkbook.Theme.ThemeFontScheme.Load themeTempFilePath
'newWorkbook.Theme.ThemeColorScheme.Load themeTempFilePath
'On Error Resume Next
'Kill themeTempFilePath ' kill = delete in VBA-speak
'On Error GoTo 0
' getWorksheetNameFromObject returns null if the worksheet object doens't
' exist
For Each sht In colSheetObjectsToCopy
sheetFriendlyName = getWorksheetNameFromObject(sourceWorkbook, sht)
Application.StatusBar = "VBL Copying " & sheetFriendlyName
If Not IsNull(sheetFriendlyName) Then
Select Case copyMethod
Case "sheet"
sourceWorkbook.Sheets(sheetFriendlyName).Copy _
After:=newWorkbook.Sheets(newWorkbook.Sheets.count)
Case "valuesWithFormatting"
newWorkbook.Sheets.Add After:=newWorkbook.Sheets(newWorkbook.Sheets.count), _
Type:=sourceWorkbook.Sheets(sheetFriendlyName).Type
sheetCount = newWorkbook.Sheets.count
newWorkbook.Sheets(sheetCount).Name = sheetFriendlyName
' Copy all cells in current source sheet to the clipboard. Could copy straight
' to the new workbook by specifying the Destination parameter but in this case
' we want to do a paste special as values only and the Copy method doens't allow that.
sourceWorkbook.Sheets(sheetFriendlyName).Cells.Copy ' Destination:=newWorkbook.Sheets(newWorkbook.Sheets.Count).[A1]
newWorkbook.Sheets(sheetCount).[A1].PasteSpecial Paste:=xlValues
newWorkbook.Sheets(sheetCount).[A1].PasteSpecial Paste:=xlFormats
newWorkbook.Sheets(sheetCount).Tab.Color = sourceWorkbook.Sheets(sheetFriendlyName).Tab.Color
Application.CutCopyMode = False
End Select
End If
Next sht
Application.StatusBar = False
Application.ScreenUpdating = True
ActiveWorkbook.Save
Sub ActiveSheet_toDESKTOP_As_Workbook()
Dim Oldname As String
Dim MyRange As Range
Dim MyWS As String
MyWS = ActiveCell.Parent.Name
Application.DisplayAlerts = False 'hide confirmation from user
Application.ScreenUpdating = False
Oldname = ActiveSheet.Name
'Sheets.Add(Before:=Sheets(1)).Name = "FirstSheet"
'Get path for desktop of user PC
Path = Environ("USERPROFILE") & "\Desktop"
ActiveSheet.Cells.Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "TransferSheet"
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells.Copy
'Create new workbook and past copied data in new workbook & save to desktop
Workbooks.Add (xlWBATWorksheet)
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells(1, 1).Select
ActiveWorkbook.ActiveSheet.Name = Oldname '"report"
ActiveWorkbook.SaveAs Filename:=Path & "\" & Oldname & " WS " & Format(CStr(Now()), "dd-mmm (hh.mm.ss AM/PM)") & ".xlsx"
ActiveWorkbook.Close SaveChanges:=True
Sheets("TransferSheet").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Worksheets(MyWS).Activate
'MsgBox "Exported to Desktop"
End Sub