VBA splitting worksheet to multiple worksheets with formula

[kbghud]

Hi,

New to the forum. I have a macro that splits one worksheet into multiple worksheets and it works great with one exception. I have a formula in Column R that I need to go into every new sheet. I have the macro splitting the worksheet based on the value of column B. It puts the formula on the new worksheet for 6, but does not do it for any other worksheet. Can anyone help me out? If anyone has a suggestion for getting it to stop creating the "blank" worksheet before 6 I'd appreciate that as well, but it's not a necessity. Thank you!

Sub Review()
'
' Review Macro
' Next Review Date
'
' Keyboard Shortcut: Ctrl+r
'
Columns("A:O").Select
Range("A2").Activate
Columns("A:O").EntireColumn.AutoFit
ActiveWindow.SmallScroll ToRight:=-6
Range("B3").Select
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 2
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A2:T2"
titlerow = 1
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

Reviews.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T
1	February 2022 Hourly Employee Review Spreadsheet
2	Location	Property	Assignment Number	EmpID	Last Name	First Name	Job Title	Start Date	Service Date	Last Incr Dt	Current Rate	Next Review	Reviewer	Reviewer Name	Type	Effective Date	New Hourly Biweekly/ Weekly Rate	% of rate change	Comments	Next Review Date
3	0006 - Jacksonville Beach Courtyard	0006	E728745	728745	Bass	Christopher	Engineer	9/11/2021		9/11/2021	15	12/11/2021	449851	Billy Hopson	H			-100.000%
4	0006 - Jacksonville Beach Courtyard	0006	E728844	728844	Caicedo	Stephanie	AM Server	9/27/2021		9/27/2021	10		726508	William Rienks	H			-100.000%
5	0006 - Jacksonville Beach Courtyard	0006	E728844-2	728844	Caicedo	Stephanie	AM Cashier	9/27/2021		9/27/2021	12		726508	William Rienks	H			-100.000%
6	0006 - Jacksonville Beach Courtyard	0006	E728844-3	728844	Caicedo	Stephanie	Lounge Bartender	9/27/2021		9/27/2021	8		726508	William Rienks	H			-100.000%
7	0006 - Jacksonville Beach Courtyard	0006	E729036	729036	Pak	Vladimir	Engineer	10/11/2021		10/11/2021	18	1/13/2022	449851	Billy Hopson	H			-100.000%
8	0065 - Durham Marriott	0065	E431435-3	431435	Flores	Victor	Line Cook	10/31/2021	9/19/2006	10/31/2021	18	2/1/2022	725945	Ruben Vera	H			-100.000%
9	0065 - Durham Marriott	0065	E460447-10	460447	Darden	Tina	Bellperson	10/24/2021		10/30/2021	14	1/1/2022	435620	Alex Reitter	H			-100.000%
10	0065 - Durham Marriott	0065	E460447-11	460447	Darden	Tina	Concierge	10/24/2021		10/30/2021	16	1/1/2022	435620	Alex Reitter	H			-100.000%
11	0065 - Durham Marriott	0065	E460447-8	460447	Darden	Tina	Line Cook	10/24/2021		10/24/2021	16	1/1/2022	435620	Alex Reitter	H			-100.000%
12	0065 - Durham Marriott	0065	E460447-9	460447	Darden	Tina	AM Server	10/24/2021		10/30/2021	13	1/1/2022	435620	Alex Reitter	H			-100.000%
13	0065 - Durham Marriott	0065	E728677	728677	Alston	Emmanuel	Dishwasher	9/11/2021		9/11/2021	13	12/1/2021	435620	Alex Reitter	H			-100.000%
14	0065 - Durham Marriott	0065	E728694	728694	Cohen	Andrew	Line Cook	9/15/2021		9/15/2021	16	12/1/2021	435620	Alex Reitter	H			-100.000%
15	0065 - Durham Marriott	0065	E728826	728826	Brown	Wesley	Engineer	9/23/2021		9/23/2021	17	12/1/2021	65060	Robert Grissom	H			-100.000%
16	0065 - Durham Marriott	0065	E728985	728985	Richardson	Sybil	Front Desk Agent	10/11/2021		10/11/2021	14	1/1/2022	725945	Ruben Vera	H			-100.000%
17	0065 - Durham Marriott	0065	E729008	729008	Mason	Nasia	Front Desk Agent	10/11/2021		10/11/2021	14	1/1/2022	725945	Ruben Vera	H			-100.000%
18	0065 - Durham Marriott	0065	E729068	729068	Jackson	DeAntwon	Security Guard	10/14/2021		10/14/2021	14	1/1/2022	725945	Ruben Vera	H			-100.000%
19	0065 - Durham Marriott	0065	E729068-2	729068	Jackson	DeAntwon	Bellperson	10/14/2021		11/14/2021	14	1/1/2022	725945	Ruben Vera	H			-100.000%
20	0065 - Durham Marriott	0065	E729074	729074	Mason	Kayla	Lounge Bartender	10/14/2021		10/14/2021	10	1/1/2022	435620	Alex Reitter	H			-100.000%
21	0065 - Durham Marriott	0065	E729169	729169	Whaley	Hermon	Security Guard	10/21/2021		10/21/2021	14	1/1/2022	435620	Alex Reitter	H			-100.000%
22	0065 - Durham Marriott	0065	E729375	729375	McCray Jr	William	Line Cook	11/3/2021		11/3/2021	16	2/3/2022	435620	Alex Reitter	H			-100.000%
23	0065 - Durham Marriott	0065	E729420	729420	Harris	Kaylah	Lounge Bartender	11/5/2021		11/5/2021	10		65008	Sharon Williams	H			-100.000%
24	0072 - Newport Harbor Hotel	0072	E729648	729648	Mullen	David	Night Auditor	11/23/2021		11/23/2021	16	2/23/2022	720859	Ian Legros	H			-100.000%
25	0075 - Edina Residence Inn	0075	E729628	729628	Vargas	Alicia	Guest Room Attendant	11/23/2021		11/23/2021	15	2/23/2022	412510	Jose Tapia Jr.	H			-100.000%
26	0075 - Edina Residence Inn	0075	E729634	729634	Rosas Martinez	Juana	Guest Room Attendant	11/23/2021		11/23/2021	15	2/23/2022	412510	Jose Tapia Jr.	H			-100.000%
27	0079 - State College Holiday Exp	0079	E428035-4	428035	Garis	Karen	Guest Room Attendant	3/7/2021	2/13/2018	8/21/2021	15	2/13/2022	442670	Laurel Stewart	H			-100.000%
28	0079 - State College Holiday Exp	0079	E451643-4	451643	Norris	Martha	Housekeeping Supervisor	5/23/2020	1/12/2012	8/21/2021	17	1/12/2022	442670	Laurel Stewart	H			-100.000%
29	0079 - State College Holiday Exp	0079	E462323-3	462323	Hill	Timothy	Engineer	5/19/2021	2/5/2018	8/21/2021	17.75	2/5/2022	79003	Ronald McElfresh	H			-100.000%
30	0079 - State College Holiday Exp	0079	E728855	728855	St Juste	Adia	Front Desk Agent	9/22/2021		9/22/2021	14		726345	Mary Sullivan	H			-100.000%
31	0080 - State College Hampton Inn	0080	E462179-3	462179	Luse	Abagael	Front Desk Agent	5/29/2020	1/8/2018	8/21/2021	15.5	1/8/2022	458190	Pamela Newberry	H			-100.000%
32	0080 - State College Hampton Inn	0080	E464671-3	464671	Offutt	Tara	Rm Inspector/Inspectress	6/4/2020	2/25/2019	8/21/2021	16	2/25/2022	458190	Pamela Newberry	H			-100.000%
33	0080 - State College Hampton Inn	0080	E729300	729300	Getgen	Tora	Guest Room Attendant	10/25/2021		10/25/2021	16	1/25/2022	458190	Pamela Newberry	H			-100.000%
34	0084 - Charleston Holiday Inn Exp	0084	E728717	728717	Browning	Martha	Floor Houseperson	9/11/2021		9/11/2021	10	12/12/2021	460433	Terri Mitchell	H			-100.000%
35	0084 - Charleston Holiday Inn Exp	0084	E728925	728925	McBride	Jamie	Guest Room Attendant	10/2/2021		10/2/2021	11	1/4/2022	460433	Terri Mitchell	H			-100.000%
36	0084 - Charleston Holiday Inn Exp	0084	E729301	729301	Tellis	Tahje	Guest Room Attendant	10/28/2021		10/28/2021	11	1/28/2022	460433	Terri Mitchell	H			-100.000%
37	0087 - Courtyard Newark At Ud	0087	E450164-5	450164	Chambers	Jessica	Lounge Bartender	5/21/2021	2/5/2011	5/21/2021	10.63	2/5/2022	452825	Joseph Foti	H			-100.000%
38	0087 - Courtyard Newark At Ud	0087	E729513	729513	Hagan	Reid	Banquet Server	11/16/2021		11/16/2021	6	2/14/2022	423267	Dawn Ackerman	H			-100.000%
Sheet1

Cell Formulas
Range	Formula
B3:B38	B3	=LEFT(A3,4)
R3:R38	R3	=((Q3-K3)/K3)

 

[Marc L]

Hi,​

​

do you need to keep the formulas in the destination sheets or just the values ?​

 

[kbghud]

The formulas should carry over to all of the destination sheets.

 

[Marc L]

According to your attachment a VBA demonstration for starters like any Excel user operating manually :​

Sub Demo1()
        Const S = "Sheet1"
        Dim Ws As Worksheet, L&, V, R&
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    For Each Ws In Worksheets
          If Ws.Name <> S Then Ws.Delete
    Next
    With Sheets(S).[A1].CurrentRegion
            L = .Rows.Count
            .Range("B2:B" & L).AdvancedFilter 2, , .Range("Z1"), True
            With .Range("Z1").CurrentRegion:  V = .Value2:  .Clear:  End With
        For R = UBound(V) To 2 Step -1
                .Parent.Copy , .Parent
            With ActiveSheet
                .Name = V(R, 1)
                .Range("A2:A" & L).AutoFilter 1, "<>" & V(R, 1) & "*"
                .Rows("3:" & L).Delete
                .[A2].AutoFilter
            End With
        Next
    End With
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub