copy sheets in workbook to new workbook

[Ctech]

This macro is to copy a wb, sheet by sheet into a new blank wk, without
formulas.
I doing this as each page have several formulas and are sheet
protected.


What happens is that the macro so everything correct, except that it
pasts blank sheets.

Please help

Macro:


Sub Copywkbookvalues()
Dim Morg
Dim Mto
Dim tWbk As Workbook
Dim cWbk As Workbook
Dim Sht As Worksheet

Set tWbk = ActiveWorkbook

Workbooks.Add
ActiveWorkbook.SaveAs Filename:= _
"X:\Users\Shared\GENERAL\Christian S\05.11.23 - Budget
Uploading LBUD3\BFR\Copy of file.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False


Set cWbk = ActiveWorkbook


On Error Resume Next
tWbk.Activate
For Each Sht In Worksheets
Sht.Select
Sht.Cells.Select
Selection.Copy
cWbk.Sheets.Add
ActiveSheet.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False



Next


End Sub

 

[Walt]

Hi Ctech,

The problem is here:
For Each Sht In Worksheets
Sht.Select
Sht.Cells.Select
Selection.Copy
cWbk.Sheets.Add '<<<<<< THIS STEP CANCELS THE CUTCOPYMODE
ActiveSheet.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Next

Any worksheet addition should be done before the copy.

I've sketched out the following which I hope will work for you:
Sub CopyWB_ValOnly()
Dim tWbk As Workbook, cWbk As Workbook, Sht As Integer
On Error GoTo CopyWB_ValOnlyERROR
Set tWbk = ActiveWorkbook
'CREATE WORKBOOK WITH ONE WORKSHEET
Set cWbk = Workbooks.Add(xlWBATWorksheet)
For Sht = 1 To tWbk.Worksheets.Count 'ALIGN WORKSHEETS COUNT
With cWbk
If .Worksheets.Count < Sht Then
.Worksheets.Add
ActiveSheet.Move _
after:=Worksheets(.Worksheets.Count)
End If
End With
Next
For Sht = 1 To tWbk.Worksheets.Count 'COPY WS NAMES AND VALUES
With cWbk
.Worksheets(Sht).Name = tWbk.Worksheets(Sht).Name
tWbk.Worksheets(Sht).Cells.Copy
.Worksheets(Sht).Cells(1, 1).PasteSpecial _
Paste:=xlValues, Operation:=xlNone
End With
Next
cWbk.SaveAs Filename:="X:\Users\Shared\GENERAL\Christian" & _
"S\05.11.23 - Budget Uploading LBUD3\BFR\Copy of file.xls"
Set tWbk = Nothing: Set cWbk = Nothing
Exit Sub
CopyWB_ValOnlyERROR:
cWbk.Close SAVECHANGES:=False
Set tWbk = Nothing: Set cWbk = Nothing
MsgBox "Error in CopyWB_ValOnly routine"
End Sub

Best Regards,
Walt Weber