VBA code to save selected sheets to a new workbook

[JonasTiger]

Hi
I found this thread
vba code to save selected sheets as new file
That works fine and fast to create a new WB from selected sheets in an existing WB

The changes I need to do is:

• available to choose the sheets (not the the last 3 that the code fits) - I need to select 6 random sheets (i.e, "Sheet1", "abb", "Sheet4", ...)
• not display zeros in allsheets in the new WB
• Filter all sheets in the new WB, based on values of a specific column

Thanks in advance
JT

 

[JonasTiger]

Do you want to filter the PLAN sheet for any value?

No, but like the other sheets, PLAN cells color should appear as the original.

 

[mumps]

If there is no data in column AB to use a filter criteria, do you want to exclude that sheet?

 

[JonasTiger]

If there is no data in column AB to use a filter criteria, do you want to exclude that sheet?

I want to copy that sheet too, as shown in the original, only values and formats.
actually the code copies the sheet with values only, but I want the colors in the cells. Code do that in the other sheets. That one is a different layout, is it possible?

 

[mumps]

Click here to download your file. This is the modified code:

Private Sub CommandButton1_Click()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    Dim c As MSForms.Control, shArr() As Variant, n As Long, ws As Worksheet, v As Variant, rng As Range, srcWB As Workbook
    Set srcWB = ThisWorkbook
    v = Array("YES", "NO", "WAIT")
    ReDim Preserve shArr(1 To 1)
    For Each c In Me.Controls
        If TypeName(c) = "CheckBox" Then
            If c.Value = True Then
                n = n + 1
                ReDim Preserve shArr(1 To n)
                shArr(n) = c.Caption
             End If
        End If
    Next c
    Sheets(shArr).Copy
    For Each ws In Sheets
        If ws.Name <> "PLAN" Then
            If WorksheetFunction.CountA(srcWB.Sheets(ws.Name).Range("AB:AB")) > 1 Then
                With ws
                    .UsedRange.Cells.Value = .UsedRange.Cells.Value
                    .Range("A1").CurrentRegion.AutoFilter 28, v, xlFilterValues
                    Set rng = ws.AutoFilter.Range
                    rng.Replace 0, "", xlWhole
                End With
            End If
        Else
            With ws.UsedRange.Cells
                .Value = .Value
                .Replace 0, "", xlWhole
            End With
        End If
    Next ws
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, chkBox As Control
    For Each ws In Sheets
        If ws.Name <> "GenerateFile" Then
            Set chkBox = Me.Controls.Add("Forms.CheckBox.1", "CheckBox" & i)
            chkBox.Caption = ws.Name
            chkBox.Left = 10
            chkBox.Top = 60 + ((i - 1) * 20)
            i = i + 1
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub
Private Sub UserForm_Activate()
    CheckSize
End Sub

Private Sub CheckSize()
    Dim h, w
    Dim c As Control
    h = 0: w = 0
    For Each c In Me.Controls
        If c.Visible Then
            If c.Top + c.Height > h Then h = c.Top + c.Height
            If c.Left + c.Width > w Then w = c.Left + c.Width
        End If
    Next c
    If h > 0 And w > 0 Then
        With Me
            .Width = w + 40
            .Height = h + 40
        End With
    End If
End Sub

Run the macro in Module2. Be patient when running the code. Please note that I deleted the first row in the first sheet.

 

[JonasTiger]

Hi Mumps
Thank you for your patience and time. I'm feeling so bad to insist.
The code works fine and quick, but...
Still the sheet "PLAN" - colors don't show up in cells like the original, cells still remain all white. is it possible to make that correction?

In addition, first code i've published include a save as for the new workbook, would you please add/adapt those lines?

Tkanks

 

[mumps]

This is a copy of the PLAN sheet after I run the macro. As you can see, all the colours are there so I don't know why the colours don't show up when you run it.

JonasTigervalues.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y
1	ABCDEFG								YES			NO			WAIT			STILL
2
3
4		AML
5		#NAME?					#NAME?					#NAME?					#NAME?					#NAME?
6
7		2022-01-24	2022-01-25	2022-01-26	2022-01-27	2022-01-28	2022-01-31	2022-02-01	2022-02-02	2022-02-03	2022-02-04	2022-02-07	2022-02-08	2022-02-09	2022-02-10	2022-02-11	2022-02-14	2022-02-15	2022-02-16	2022-02-17	2022-02-18	2022-02-21	2022-02-22	2022-02-23	2022-02-24
8				322	428	385	167	720	614	465	450	256	516
9				321	427	384	121	719	613		299	176	306
10				159	426	383	74	280	612		170	114	296
11					425	210	73	279	340		113
12					424	209		177
13					423	208		140
14					422
15
16
17
18
19		AMP
20		#NAME?					#NAME?					#NAME?					#NAME?					#NAME?
21
22		2022-01-24	2022-01-25	2022-01-26	2022-01-27	2022-01-28	2022-01-31	2022-02-01	2022-02-02	2022-02-03	2022-02-04	2022-02-07	2022-02-08	2022-02-09	2022-02-10	2022-02-11	2022-02-14	2022-02-15	2022-02-16	2022-02-17	2022-02-18	2022-02-21	2022-02-22	2022-02-23	2022-02-24
23									1179		1249	1419	1476	1282
24									1003		1110	1081	1475	1121
25									994		1109		1474	1073
26											1108		1034	1072
27											1015		1033	970
28													1032	931
29
30
31
32
33
34		NORUP
35		#NAME?					#NAME?					#NAME?					#NAME?					#NAME?
36
37		2022-01-24	2022-01-25	2022-01-26	2022-01-27	2022-01-28	2022-01-31	2022-02-01	2022-02-02	2022-02-03	2022-02-04	2022-02-07	2022-02-08	2022-02-09	2022-02-10	2022-02-11	2022-02-14	2022-02-15	2022-02-16	2022-02-17	2022-02-18	2022-02-21	2022-02-22	2022-02-23	2022-02-24
38															2346	2451	2469	2478	2450
39															2258	2352	2468	2477	2385
40															2257	2301	2275	2476	2315
41															2256	2248	2274	2475
42															2255			2474
43																		2473
44
45
46
47
48
49		CEMID
50		#NAME?					#NAME?					#NAME?					#NAME?					#NAME?
51
52		2022-01-24	2022-01-25	2022-01-26	2022-01-27	2022-01-28	2022-01-31	2022-02-01	2022-02-02	2022-02-03	2022-02-04	2022-02-07	2022-02-08	2022-02-09	2022-02-10	2022-02-11	2022-02-14	2022-02-15	2022-02-16	2022-02-17	2022-02-18	2022-02-21	2022-02-22	2022-02-23	2022-02-24
53							1891	1864		1866		2110		1527	1913	1917
54							1739	1695		1865				1526	1912
55							1738	1694		1742				1525	1911
56							1585	1693		1569				1497	1910
57							1555	1644						1496	1909
58							1533	1643						1495	1908
59														1494	1907
60															1906
61															1905
62
63
64		SOUDOWN
65		#NAME?					#NAME?					#NAME?					#NAME?					#NAME?
66
67		2022-01-24	2022-01-25	2022-01-26	2022-01-27	2022-01-28	2022-01-31	2022-02-01	2022-02-02	2022-02-03	2022-02-04	2022-02-07	2022-02-08	2022-02-09	2022-02-10	2022-02-11	2022-02-14	2022-02-15	2022-02-16	2022-02-17	2022-02-18	2022-02-21	2022-02-22	2022-02-23	2022-02-24
68								2870	2861		2728	2836
69								2755			2727	2835
70								2694			2726	2834
71								2693			2725	2833
72								2692			2701	2832
73								2691			2700	2831
74												2738
PLAN

Try this revised macro:

Private Sub CommandButton1_Click()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    Dim c As MSForms.Control, shArr() As Variant, n As Long, ws As Worksheet, v As Variant
    Dim rng As Range, srcWB As Workbook, p As Long, newXlsxFullName As String
    Set srcWB = ThisWorkbook
    p = InStrRev(srcWB.FullName, ".")
    newXlsxFullName = Left(srcWB.FullName, p - 1) & "values.xlsx"
    v = Array("YES", "NO", "WAIT")
    ReDim Preserve shArr(1 To 1)
    For Each c In Me.Controls
        If TypeName(c) = "CheckBox" Then
            If c.Value = True Then
                n = n + 1
                ReDim Preserve shArr(1 To n)
                shArr(n) = c.Caption
             End If
        End If
    Next c
    Sheets(shArr).Copy
    For Each ws In Sheets
        If ws.Name <> "PLAN" Then
            If WorksheetFunction.CountA(srcWB.Sheets(ws.Name).Range("AB:AB")) > 1 Then
                With ws
                    .UsedRange.Cells.Value = .UsedRange.Cells.Value
                    .Range("A1").CurrentRegion.AutoFilter 28, v, xlFilterValues
                    Set rng = ws.AutoFilter.Range
                    rng.Replace 0, "", xlWhole
                End With
            End If
        Else
            With ws.UsedRange.Cells
                .Value = .Value
                .Replace 0, "", xlWhole
            End With
        End If
    Next ws
    On Error Resume Next
    With ActiveWorkbook
        Application.DisplayAlerts = False
        .SaveAs newXlsxFullName, FileFormat:=xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        .Close SaveChanges:=False
        If Err.Number = 0 Then
            MsgBox "Saved " & newXlsxFullName, vbInformation
        Else
            MsgBox "Error saving " & newXlsxFullName & vbCrLf & vbCrLf & "Error number " & Err.Number & vbCrLf & Err.Description, vbExclamation
        End If
    End With
    On Error GoTo 0
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    Unload Me
End Sub

 

[JonasTiger]

I wish I understand too
You´ve done a great job, Tank you very much.
Everything works very fine except that "thing".
I'm testing in the same file I sent you and "bug" still remains:

Is this about EXCEL version? I'm working v2019 and 365

 

[mumps]

I'm not sure what the problem is because the code simply copies the whole sheet as is.

 

[JonasTiger]

I'm not sure what the problem is because the code simply copies the whole sheet as is.

I think there's a bug for sure, I tested in original file and in two more testfiles, all of them with the same layout, and result is always diferent in this sheet "PLAN" - some with values, some with blanks, but none with colored cells.
Another thing that happens is Excel ShutDown, everytime the macro runs

 

[mumps]

I'm sorry but I can't seem to reproduce the problem.