Paste Special values for entire workbook

[Chris Maddogz]

I have 5 sheets A,B,C,D,E in a work book X & each of B,C,D and E have links
to cells in sheet A.
I need a macro to copy workbook X to to a new workbook Y using the same
sheetnames as in X but for the new A,B,C,D & E sheets in Y to have all links
removed.

 

[OssieMac]

Hi Chris,

I wonder if you really need a macro to do this?
Save the workbook as a new filename.
Hold the Ctrl key down while you select each of the worksheets. Or select
the first worksheet and hold the Shift key while you select the last
worksheet. (Either method selects multiple worksheets).
Click on the rectangle where the column and row identifiers meet (top left
of worksheet) to select entire worksheet/s.
Copy -> Paste Special -> Values.

 

[Chris Maddogz]

I realise I can do this manually but I need to automate it for the office
users so as to avoid any problems

 

[OssieMac]

OK Chris. What version of xl are you using?

 

[Chris Maddogz]

Using 2007 but macro will also run on previous version

 

[OssieMac]

Hi again Chris,

The code gives you the option of entering a new file name via an InputBox.
If you don't want the InputBox and prefer a fixed file name then see the
comments and you can delete the InputBox method and edit the following line
with your filename of choice. (The leading single quote must be removed also.)
'strNewFileName = "Copy of Master.xls"

The input box defaults to a file name prefixed with 'Copy of' and the master
filename. You can edit that name to any valid file name. The .xls extension
is optional. (if .xls extension not inserted then the code inserts it.)

NOTE: I don't believe there is anything that can damage your master file but
I always advise to back up your file before installing the code just in case.

Copy the code into a module in the master workbook. The code will NOT be
copied to the new workbook.

The new file saves as Excel 97-2003 file type so that it is suitable for
xl2007 in compatibility mode and with earlier versions of xl.

Sub CopyWorkBook()
Dim wbThis As Workbook
Dim wbCopy As Workbook
Dim strPath As String
Dim strNewFileName As String
Dim strDirTest As String
Dim msgResponse

Set wbThis = ThisWorkbook

strPath = wbThis.Path & "\"

'Start of InputBox method**************************
strNewFileName = Application.InputBox _
("Enter name for new file." & vbCrLf & _
"(May exclude the file extension.)", _
"Get Filename", "Copy of " & wbThis.Name, 2)

If InStr(1, strNewFileName, ".xls") = 0 Then
strNewFileName = strNewFileName & ".xls"
End If

strDirTest = Dir(strPath & strNewFileName)

If strDirTest <> "" Then
msgResponse = MsgBox("Filename " & _
strNewFileName & " already exists." & _
vbCrLf & "Do you want to replace it?", _
vbYesNo)
If msgResponse = vbNo Then
MsgBox "Processing will terminate." & _
vbCrLf & _
"Run program again and enter" & _
" different filename."
Exit Sub
End If
End If
'End InputBox method*************************

'Can use following line in lieu of InputBox
'strNewFileName = "Copy of Master.xls"

wbThis.Sheets(Array("Sheet1", "Sheet2", _
"Sheet3")).Select
wbThis.Sheets("Sheet3").Activate
wbThis.Sheets(Array("Sheet1", "Sheet2", _
"Sheet3")).Copy

Set wbCopy = ActiveWorkbook
wbCopy.Sheets(Array("Sheet1", "Sheet2", _
"Sheet3")).Select
wbCopy.Sheets("Sheet1").Activate
Cells.Select
Selection.Copy
Selection.PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Range("A1").Select
Sheets("Sheet1").Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
wbCopy.SaveAs Filename:= _
strPath & strNewFileName, _
FileFormat:=xlNormal, Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
Application.DisplayAlerts = True
ActiveWindow.Close
End Sub

 

[OssieMac]

Hello again Chris,

I suggest that you use the following code in lieu of my previous post. I
found and fixed some problems with it and now it is also generic for the
number of worksheets that you have in the workbook to be copied.

Tested in xl2007 and xl2002. However, always saves new workbook as xl97-2003
format.

Sub CopyWorkBook()

Dim wbThisWb As Workbook
Dim wbCopyWb As Workbook
Dim strPath As String
Dim strNewFileName As String
Dim intDotPos As Integer
Dim strDirTest As String
Dim msgResponse
Dim intShtsCount As Integer
Dim shtArray()
Dim i As Integer

Set wbThisWb = ThisWorkbook

strPath = wbThisWb.Path & "\"

'Start of InputBox method**************************
strNewFileName = wbThisWb.Name
intDotPos = InStr(strNewFileName, ".")
strNewFileName = Left(strNewFileName, intDotPos - 1)

strNewFileName = Application.InputBox _
("Enter name for new file." & vbCrLf & _
"(May exclude the file extension.)", _
"Get Filename", "Copy of " & strNewFileName, 2)

'Remove .xlsm file extension if present
If InStr(1, strNewFileName, ".xlsm") > 0 Then
strNewFileName = Replace(strNewFileName, ".xlsm", "", 1)
End If

'Append .xls file extension if not present
If InStr(1, strNewFileName, ".xls") = 0 Then
strNewFileName = strNewFileName & ".xls"
End If

strDirTest = Dir(strPath & strNewFileName)

If strDirTest <> "" Then
msgResponse = MsgBox("Filename " & _
strNewFileName & " already exists." & _
vbCrLf & "Do you want to replace it?", _
vbYesNo)
If msgResponse = vbNo Then
MsgBox "Processing will terminate." & _
vbCrLf & _
"Run program again and enter" & _
" different filename."
Exit Sub
End If
End If
'End InputBox method*************************

'Can use following line in lieu of InputBox
'strNewFileName = "Copy of Master.xls"

With wbThisWb
intShtsCount = .Sheets.Count

ReDim shtArray(0 To intShtsCount - 1)

For i = 0 To intShtsCount - 1
shtArray(i) = (i + 1)
Next i

.Sheets(shtArray).Select
.Sheets(1).Activate
.Sheets(shtArray).Copy
End With

Set wbCopyWb = ActiveWorkbook

With wbCopyWb
.Sheets(shtArray).Select
.Sheets(1).Activate
Cells.Select
Selection.Copy
Selection.PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Range("A1").Select
.Sheets(1).Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
.SaveAs Filename:= _
strPath & strNewFileName, _
FileFormat:=xlNormal, Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
Application.DisplayAlerts = True
.Close
End With

With wbThisWb
.Sheets(1).Select
Range("A1").Select
End With

End Sub

 

[Chris Maddogz]

Thanks for that its doing the job