Excel sheet: Copy data from one workbook to another workbook - vba

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

Related

Copy data from one excel workbook to another while retaining formatting

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.

Accessing csv-file via a path saved in another csv-file

I want to combine two csv into one new csv file via a vba macro but have problems accessing the values of the two files.
I can open the first file with Workbooks.Open() but I can not access any of its values by File1.ActiveSheet.Cells(1,1) or File1.ActiveSheet.Range(1,1) etc.
The catch is, that I have to open the second file through a path that is contained in the first file.
The Files look like this:
File1
File2
For every ID in File1 there is one File2 with about ~30000-60000 entrys that need to be mapped together.
My Idea was to copy File2 into the new File and than add the ID for every row.
I can not just change the File2 and ad the ID there since I have no writting rights to the Folder they are in.
The Struktur the Files are in at the Moment:
WorkingDir |
|___File1
|___Macro
|___allFile2
.........|__File2_1
.........|__File2_2
Is there a better approach to this?
I am new to vba programming and have almost no practise in it i would be really greatful if someone can help me or has some literatur that could help.
I would create another worksheet that can be used a medium for importation. What you would be doing is creating a macro that enables you to select another file from a open file window and then another macro that will copy and paste the desired data range. If you want to create a macro that integrates it into the other file you could do that as well.
Here is an example of how you might structure the File Select code:
Sub GetFile()
'Dim the variables
Dim FileSelect As Variant
Dim wb As Workbook
Dim i As Integer
'on error statement
On Error GoTo errHandler:
'hold in memory
Application.ScreenUpdating = False
'locate the file path
FileSelect = Application.GetOpenFilename(filefilter:="Excel Files,*.xl*", _
MultiSelect:=False)
'check if a file is selected
If FileSelect = False Then
MsgBox "Select the file name"
Exit Sub
End If
'send the path to the worksheet
Sheet8.Range("C4").Value = FileSelect
'open the workbook
Set wb = Workbooks.Open(FileSelect)
'add the sheet names to the workbook
'close the workbook
wb.Close False
Application.ScreenUpdating = True
Exit Sub
This would be an example of your importation code:
Public Sub GetRange()
'Dim variables
Dim FileSelect As Variant
Dim wb As Workbook
Dim Addme As Range, _
CopyData As Range, _
Bk As Range, _
Sh As Range, _
St As Range, _
Fn As Range, _
Tb As Range, _
c As Range
'on error statement
On Error GoTo errHandler:
'hold values in memory
Application.ScreenUpdating = False
'check neccessary cells have values
For Each c In Sheet8.Range("C4,F4,G4,H4")
If c.Value = "" Then
MsgBox "You have left out a value that is needed in " & c.Address
Exit Sub
End If
Next c
'set the range reference variables
Set Bk = Sheet8.Range("C4") 'file path of book to import from
Set Sh = Sheet8.Range("G4") 'Worksheet to import
Set St = Sheet8.Range("G4") 'starting cell reference
Set Fn = Sheet8.Range("H4") 'finishing cell reference
'set the destination
Set Addme = Sheet8.Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
'open the workbook
Set wb = Workbooks.Open(Bk)
'set the copy range
Set CopyData = Worksheets(Sh.Value).Range(St & ":" & Fn)
'copy and paste the data
CopyData.Copy
Addme.PasteSpecial xlPasteValues
'clear the clipboard
Application.CutCopyMode = False
'close the workbook
wb.Close False
'return to the interface sheet
Sheet8.Select
End With
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 notify the administrator"
End Sub
This is merely an example of how you would structure it generally. You would need to build the excel worksheet for the references needed for the variables listed in the code.
A great resource for this subject is found at this website: http://www.onlinepclearning.com/import-data-into-excel-vba/
Hope this helps!

Excel: macro to export worksheet as CSV file without leaving my current Excel sheet

There are a lot of questions here to create a macro to save a worksheet as a CSV file. All the answers use the SaveAs, like this one from SuperUser. They basically say to create a VBA function like this:
Sub SaveAsCSV()
ActiveWorkbook.SaveAs FileFormat:=clCSV, CreateBackup:=False
End Sub
This is a great answer, but I want to do an export instead of Save As. When the SaveAs is executed it causes me two annoyances:
My current working file becomes a CSV file. I'd like to continue working in my original .xlsm file, but to export the contents of the current worksheet to a CSV file with the same name.
A dialog appears asking me confirm that I'd like to rewrite the CSV file.
Is it possible to just export the current worksheet as a file, but to continue working in my original file?
#NathanClement was a bit faster. Yet, here is the complete code (slightly more elaborate):
Option Explicit
Public Sub ExportWorksheetAndSaveAsCSV()
Dim wbkExport As Workbook
Dim shtToExport As Worksheet
Set shtToExport = ThisWorkbook.Worksheets("Sheet1") 'Sheet to export as CSV
Set wbkExport = Application.Workbooks.Add
shtToExport.Copy Before:=wbkExport.Worksheets(wbkExport.Worksheets.Count)
Application.DisplayAlerts = False 'Possibly overwrite without asking
wbkExport.SaveAs Filename:="C:\tmp\test.csv", FileFormat:=xlCSV
Application.DisplayAlerts = True
wbkExport.Close SaveChanges:=False
End Sub
Almost what I wanted #Ralph, but here is the best answer, because it solves some annoyances in your code:
it exports the current sheet, instead of just the hardcoded sheet named "Sheet1";
it exports to a file named as the current sheet
it respects the locale separation char.
You continue editing your xlsx file, instead of editing the exported CSV.
To solve these problems, and meet all my requirements, I've adapted the code from here. I've cleaned it a little to make it more readable.
Option Explicit
Sub ExportAsCSV()
Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
Dim Change below to "- 4" to become compatible with .xls files
MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, Len(CurrentWB.Name) - 5) & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Note some characteristics of the code above:
It works just if the current filename has 4 letters, like .xlsm. Wouldn't work in .xls excel old files. For file extensions of 3 chars, you must change the - 5 to - 4 when setting MyFileName in the code above.
As a collateral effect, your clipboard will be substituted with current sheet contents.
Edit: put Local:=True to save with my locale CSV delimiter.
As per my comment on #neves post, I slightly improved this by adding the xlPasteFormats as well as values part so dates go across as dates - I mostly save as CSV for bank statements, so needed dates.
Sub ExportAsCSV()
Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
'Dim Change below to "- 4" to become compatible with .xls files
MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, Len(CurrentWB.Name) - 5) & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
Here is a slight improvement on the this answer above taking care of both .xlsx and .xls files in the same routine, in case it helps someone!
I also add a line to choose to save with the active sheet name instead of the workbook, which is most practical for me often:
Sub ExportAsCSV()
Dim MyFileName As String
Dim CurrentWB As Workbook, TempWB As Workbook
Set CurrentWB = ActiveWorkbook
ActiveWorkbook.ActiveSheet.UsedRange.Copy
Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, InStrRev(CurrentWB.Name, ".") - 1) & ".csv"
'Optionally, comment previous line and uncomment next one to save as the current sheet name
'MyFileName = CurrentWB.Path & "\" & CurrentWB.ActiveSheet.Name & ".csv"
Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
For those situations where you need a bit more customisation of the output (separator or decimal symbol), or who have large dataset (over 65k rows), I wrote the following:
Option Explicit
Sub rng2csv(rng As Range, fileName As String, Optional sep As String = ";", Optional decimalSign As String)
'export range data to a CSV file, allowing to chose the separator and decimal symbol
'can export using rng number formatting!
'by Patrick Honorez --- www.idevlop.com
Dim f As Integer, i As Long, c As Long, r
Dim ar, rowAr, sOut As String
Dim replaceDecimal As Boolean, oldDec As String
Dim a As Application: Set a = Application
ar = rng
f = FreeFile()
Open fileName For Output As #f
oldDec = Format(0, ".") 'current client's decimal symbol
replaceDecimal = (decimalSign <> "") And (decimalSign <> oldDec)
For Each r In rng.Rows
rowAr = a.Transpose(a.Transpose(r.Value))
If replaceDecimal Then
For c = 1 To UBound(rowAr)
'use isnumber() to avoid cells with numbers formatted as strings
If a.IsNumber(rowAr(c)) Then
'uncomment the next 3 lines to export numbers using source number formatting
' If r.cells(1, c).NumberFormat <> "General" Then
' rowAr(c) = Format$(rowAr(c), r.cells(1, c).NumberFormat)
' End If
rowAr(c) = Replace(rowAr(c), oldDec, decimalSign, 1, 1)
End If
Next c
End If
sOut = Join(rowAr, sep)
Print #f, sOut
Next r
Close #f
End Sub
Sub export()
Debug.Print Now, "Start export"
rng2csv shOutput.Range("a1").CurrentRegion, RemoveExt(ThisWorkbook.FullName) & ".csv", ";", "."
Debug.Print Now, "Export done"
End Sub
You can use Worksheet.Copy with no arguments to copy the worksheet to a new workbook. Worksheet.Move will copy the worksheet to a new workbook and remove it from the original workbook (you might say "export" it).
Grab a reference to the newly created workbook and save as CSV.
Set DisplayAlerts to false to suppress the warning messages. (Don't forget to turn it back on when you're done).
You will want DisplayAlerts turned off when you save the workbook and also when you close it.
wsToExport.Move
With Workbooks
Set wbCsv = .Item(.Count)
End With
Application.DisplayAlerts = False
wbCsv.SaveAs xlCSV
wbCsv.Close False
Application.DisplayAlerts = True
As I commented, there are a few places on this site that write the contents of a worksheet out to a CSV. This one and this one to point out just two.
Below is my version
it explicitly looks out for "," inside a cell
It also uses UsedRange - because you want to get all of the contents in the worksheet
Uses an array for looping as this is faster than looping through worksheet cells
I did not use FSO routines, but this is an option
The code ...
Sub makeCSV(theSheet As Worksheet)
Dim iFile As Long, myPath As String
Dim myArr() As Variant, outStr As String
Dim iLoop As Long, jLoop As Long
myPath = Application.ActiveWorkbook.Path
iFile = FreeFile
Open myPath & "\myCSV.csv" For Output Lock Write As #iFile
myArr = theSheet.UsedRange
For iLoop = LBound(myArr, 1) To UBound(myArr, 1)
outStr = ""
For jLoop = LBound(myArr, 2) To UBound(myArr, 2) - 1
If InStr(1, myArr(iLoop, jLoop), ",") Then
outStr = outStr & """" & myArr(iLoop, jLoop) & """" & ","
Else
outStr = outStr & myArr(iLoop, jLoop) & ","
End If
Next jLoop
If InStr(1, myArr(iLoop, jLoop), ",") Then
outStr = outStr & """" & myArr(iLoop, UBound(myArr, 2)) & """"
Else
outStr = outStr & myArr(iLoop, UBound(myArr, 2))
End If
Print #iFile, outStr
Next iLoop
Close iFile
Erase myArr
End Sub

Save select sheets to HTML using VBA

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

How to copy only a single worksheet to another workbook using vba

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