Sub test()
Dim Newbook As Object, SourceWorkbook As Object
Dim cnt As Integer, PageCollect As Collection, tempworksheet As Worksheet
Set SourceWorkbook = ThisWorkbook
Set PageCollect = New Collection
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'add sheets to collection
For Each tempworksheet In SourceWorkbook.Worksheets
If SourceWorkbook.Sheets(tempworksheet.Name).Name <> "Sheet1" Then
PageCollect.Add SourceWorkbook.Sheets(tempworksheet.Name)
End If
Next tempworksheet
'add new wb. Transfer sheets. Save to same path with same name in .xlsx format
Set Newbook = Workbooks.Add
With Newbook
For cnt = 1 To PageCollect.Count
PageCollect(cnt).Copy After:=Newbook.Sheets(Newbook.Sheets.Count)
Next cnt
.SaveAs Filename:=ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, _
Len(ThisWorkbook.Name) - 5) & ".xlsx", FileFormat:=51
.Close
End With
ErrHandler:
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "Error"
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set Newbook = Nothing
Set SourceWorkbook = Nothing
End Sub
Thank you. This is what is really needed.Hi sofas. You can trial this code. HTH. Dave
VBA Code:Sub test() Dim Newbook As Object, SourceWorkbook As Object Dim cnt As Integer, PageCollect As Collection, tempworksheet As Worksheet Set SourceWorkbook = ThisWorkbook Set PageCollect = New Collection On Error GoTo ErrHandler Application.ScreenUpdating = False Application.DisplayAlerts = False 'add sheets to collection For Each tempworksheet In SourceWorkbook.Worksheets If SourceWorkbook.Sheets(tempworksheet.Name).Name <> "Sheet1" Then PageCollect.Add SourceWorkbook.Sheets(tempworksheet.Name) End If Next tempworksheet 'add new wb. Transfer sheets. Save to same path with same name in .xlsx format Set Newbook = Workbooks.Add With Newbook For cnt = 1 To PageCollect.Count PageCollect(cnt).Copy After:=Newbook.Sheets(Newbook.Sheets.Count) Next cnt .SaveAs Filename:=ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, _ Len(ThisWorkbook.Name) - 5) & ".xlsx", FileFormat:=51 .Close End With ErrHandler: If Err.Number <> 0 Then On Error GoTo 0 MsgBox "Error" End If Application.ScreenUpdating = True Application.DisplayAlerts = True Set Newbook = Nothing Set SourceWorkbook = Nothing End Sub
Sub Save_As_Non_Macro()
Dim sh As Worksheet, shArr
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> "Sheet1" Then shArr = shArr & "|" & sh.Name
Next sh
shArr = Split(Mid(shArr, 2), "|")
Sheets(shArr).Copy
With ActiveWorkbook
Application.DisplayAlerts = False
.SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & ".xlsx", FileFormat:=51
Application.DisplayAlerts = True
.Close
End With
End Sub
Sub test()
Dim Wb As Workbook, Ws As Worksheet
Dim F As Workbook, filePath As String, Cpt()
filePath = Application.ActiveWorkbook.Path: Set Sh = Sheets'("Sheet1")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
Set Wb = ActiveWorkbook: Set F = Workbooks.Add
For Each Ws In Wb.Worksheets
If Ws.Name <> Sh.Name Then
n = n + 1
ReDim Preserve Cpt(1 To n)
Cpt(n) = Ws.Name
End If
Next Ws
Wb.Sheets(Cpt).Copy After:=F.Sheets(F.Sheets.Count)
On Error Resume Next: F.Sheets(1).Delete: On Error GoTo 0
Application.ActiveWorkbook.SaveAs Filename:=filePath & "\" & Wb.Name & ".xlsx"
F.Close
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Or
Code:Sub Save_As_Non_Macro() Dim sh As Worksheet, shArr For Each sh In ThisWorkbook.Worksheets If sh.Name <> "Sheet1" Then shArr = shArr & "|" & sh.Name Next sh shArr = Split(Mid(shArr, 2), "|") Sheets(shArr).Copy With ActiveWorkbook Application.DisplayAlerts = False .SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & ".xlsx", FileFormat:=51 Application.DisplayAlerts = True .Close End With End Sub
Welcome. jolivanesOr
Code:Sub Save_As_Non_Macro() Dim sh As Worksheet, shArr For Each sh In ThisWorkbook.Worksheets If sh.Name <> "Sheet1" Then shArr = shArr & "|" & sh.Name Next sh shArr = Split(Mid(shArr, 2), "|") Sheets(shArr).Copy With ActiveWorkbook Application.DisplayAlerts = False .SaveAs ThisWorkbook.Path & "\" & Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & ".xlsx", FileFormat:=51 Application.DisplayAlerts = True .Close End With End Sub
really sorry. My fault: Yes, it works very well. Short and nice code.what is the message and which line is marked?
What have you changed for the code to work on your workbook?
It works on a trial file here. Do you have a sheet named "Sheet1"