Create Copies of a Worksheet Based on a Range with a Set Criteria

I have a workbook containing two worksheets, the first worksheet called 'Summary' contains an ID in column A and a Status in column B. The second worksheet called 'Template' would be hidden (I've left it unhidden in the attached sample) is effectively a template which would have numerous cells containing various different formulas.

What I would like to be able to do is have a macro activated by a button on the 'Summary' worksheet that when run creates a new worksheet for every ID in column A that has the corresponding status of 'Complete' in column B.

The newly created worksheet name should match those IDs. I also then need cell C5 to be populated with the corresponding ID on each newly created worksheet, so e.g. when the macro is run, a copy of the 'Template' worksheet would be created with the worksheet named AB124 and cell C5 will have AB124 entered in it and likewise for every instance where the ID in column A shows 'Complete' in column B. So in the attached sample when the macro is run it will create 15 copies of the hidden worksheet 'Template' (leaving 'the 'Template' worksheet hidden), each one named according to the IDs in column A showing 'Complete' in column B and each with the corresponding ID entered into cell C5.

Is this actually possible to achieve?

Many thanks

Try this.

Sub CreateSheets()
Dim arrNames, c
arrNames = Worksheets("Summary").Cells(1).CurrentRegion
Application.ScreenUpdating = False
Worksheets("Template").Visible = True
    For c = LBound(arrNames, 1) + 1 To UBound(arrNames, 1)
            If arrNames(c, 2) = "Complete" Then
                Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
                    With ActiveSheet
                        .Name = arrNames(c, 1)
                        .Cells(5, "C").Value = .Name
                    End With
            End If
    Next c
Worksheets("Summary").Activate
Range("A1").Select
Application.ScreenUpdating = True
Worksheets("Template").Visible = False
End Sub

Hi skywriter,

That works perfectly, many many thanks...

I need to add one additional function. Once the new sheets have been created, based on 'Complete', I need to change the cells from 'Complete' on the Summary page to 'Finished'. Through trial and error I added this code after Worksheets("Summary").Activate

    Range(Range("B2"), Range("B2").End(xlDown)).Select
    Selection.Replace What:="Complete", Replacement:="Finished", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False

It works, but is there a better or more efficient was to do this?

Maybe this.

Sub CreateSheets()
Dim arrNames, c
arrNames = Worksheets("Summary").Cells(1).CurrentRegion
Application.ScreenUpdating = False
Worksheets("Template").Visible = True
    For c = LBound(arrNames, 1) + 1 To UBound(arrNames, 1)
            If arrNames(c, 2) = "Complete" Then
                arrNames(c, 2) = "Finished"
                Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
                    With ActiveSheet
                        .Name = arrNames(c, 1)
                        .Cells(5, "C").Value = .Name
                    End With
            End If
    Next c
        With Worksheets("Summary")
            .Cells(1).CurrentRegion.Value = arrNames
            .Activate
            .Range("A1").Select
        End With
    Worksheets("Template").Visible = False
    Application.ScreenUpdating = True
End Sub

Hi Hangman and Skywriter,

Here's my offering - the forum was down earlier

Sub Hangman(): Dim ws As Worksheet, wt As Worksheet, wa As Worksheet, s As Long
Set ws = Sheets("Summary"): Set wt = Sheets("Template")
        For s = 2 To ws.Range("A" & Rows.count).End(xlUp).Row
            If ws.Range("B" & s) = "Complete" Then
                wt.Copy After:=Worksheets(Worksheets.count)
        Set wa = Worksheets(Worksheets.count): wa.Visible = xlSheetVisible
        wa.Name = ws.Range("A" & s): wa.Range("C5") = ws.Range("A" & s)
                    ws.Range("B" & s) = "Finished"
            End If
        Next s
End Sub

*it runs with Template hidden

@skywriter - that works perfectly and really quickly and efficiently... Many thanks for your help, the perfect solution.

@xladept - thanks for this also, though the code runs much slower than skywriter's, you can visually see it looping as it creates new tabs and it also appears to make a copy/replaces the 'Template' tab calling it 'Template2' which means the code won't run second time around (unless I rename 'Template2' back to 'Template') because the 'Template' tab no longer exists.

I'm grateful to you both for taking the time to help...

HangMan,
Thanks for the rep. points.

Hi Hangman,

It runs with the template hidden and takes .42 seconds on my machine
The copy procedure affixes the (2) but the routine renames it immediately??

Skywriter, can you try my code and see if it's slow for you?

Orrin

@xladept - Not a criticism, I'm running a virtual copy of Windows on Mac OSX, I simply ran both your code and skywriter's code and I was seeing a noticeable difference/lag in the time it took to create the new tabs running your code when compared to skywriter's. It's not like it is a problem and it could easily be my system but my actual sheet has some 5,000 rows so the problem is perhaps exaggerated as well as a result.

If I run your code then delete all the newly created tabs and rename the 'Finished' back to 'Complete' on the 'Summary' tab and re-run your code it errors because it can't find 'Template' because it no longer exists, only 'Template2'. If I then unhide 'Template2' and rename it 'Template' the code runs okay again.

Please don't get me wrong, I'm still very grateful, I just wanted to point out the fact I was getting an error second time around and that running both your code and skywriter's code I'm seeing a noticeable visual difference in the time it takes to complete the task...

Skywriter, can you try my code and see if it's slow for you?

Well I started it, went to Disneyland, came home, still not done. Oh wait, it just finished.

Just kidding, it seemed fine, maybe turn off screen updating and it'll go a little faster. With yours you see the sheets being created, which probably gives the perception that it's slower, but I don't think it is.

@xladept - Not a criticism, I'm running a virtual copy of Windows on Mac OSX, I simply ran both your code and skywriter's code and I was seeing a noticeable difference/lag in the time it took to create the new tabs running your code when compared to skywriter's. It's not like it is a problem and it could easily be my system but my actual sheet has some 5,000 rows so the problem is perhaps exaggerated as well as a result.

If I run your code then delete all the newly created tabs and rename the 'Finished' back to 'Complete' on the 'Summary' tab and re-run your code it errors because it can't find 'Template' because it no longer exists, only 'Template2'. If I then unhide 'Template2' and rename it 'Template' the code runs okay again.

Please don't get me wrong, I'm still very grateful, I just wanted to point out the fact I was getting an error second time around and that running both your code and skywriter's code I'm seeing a noticeable visual difference in the time it takes to complete the task...


I ran a best of five creating 20 new tabs and these were the results (in seconds) on my 'slow' system :-) and the thing to check is running the code a second time, there 'is' an issue because the 'Template' tab is renamed, so your code won't run without error a second time without renaming the tab...

macro timings.jpg

I don't know if it is possible to extend the code further to delete rows on the newly created sheets meeting a certain criteria. I've set up a new post here to explain:

http://www.excelforum.com/excel-prog...ml#post4224801

Many thanks all is working really well... greatly appreciated...

Hi Hangman,

Thanks for the rep!

I was totally frustrated yesterday because for my server the forum wouldn't come up and I couldn't answer your posts.

It must be the renaming that your Virtual Mac creates - a possible solution is to name it back every time

Also, the screen updating like in Skywriters Code could make a difference - so here's a correction that runs in .41s:

Sub Hangman(): Dim ws As Worksheet, wt As Worksheet, wa As Worksheet, s As Long
    Set ws = Sheets("Summary"): Set wt = Sheets("Template")
    Application.ScreenUpdating = False
        For s = 2 To ws.Range("A" & Rows.count).End(xlUp).Row
            If ws.Range("B" & s) = "Complete" Then
        wt.Copy After:=Worksheets(Worksheets.count):' wt.Name = "Template" 'didn't work:(
        Set wa = Worksheets(Worksheets.count): wa.Visible = xlSheetVisible
        wa.Name = ws.Range("A" & s): wa.Range("C5") = ws.Range("A" & s)
                    ws.Range("B" & s) = "Finished"
            End If
        Next s
        Application.ScreenUpdating = True
End Sub

Hi xladept,

Many thanks for this, I know what you mean, the server has been up and down all weekend, mostly down, so yes, very frustrating for me too...

This runs a million times faster, so thanks for that. There is still an issue however because the hidden worksheet called 'Template' is being renamed 'Template(2)' when the code runs, so if you run the code, then delete all the new worksheets it creates and then rename 'Finished' back to 'Complete' on the 'Summary' sheet and run the code again it will error because it can't locate the workbook 'Template' as it no longer exists.

Hi Hangman,

I guess old Skywriter knew something I didn't (no big surprise) - running with the Template visible is much quicker and reliable - this, with the new code shamelessly plagiarized from GC Excel runs in just .16s:

Sub Hangman(): Dim ws As Worksheet, wt As Worksheet, wa As Worksheet
                        Dim s As Long, r As Long
Set ws = Sheets("Summary"): Set wt = Sheets("Template")
wt.Visible = xlSheetVisible:    Application.ScreenUpdating = False
        For s = 2 To ws.Range("A" & Rows.count).End(xlUp).Row
            If ws.Range("B" & s) = "Complete" Then
        wt.Copy After:=Worksheets(Worksheets.count)
        Set wa = Worksheets(Worksheets.count): wa.Visible = xlSheetVisible
        wa.Name = ws.Range("A" & s): wa.Range("C5") = ws.Range("A" & s)
                    For r = 19 To 10 Step -1
If wa.Range("E" & r).Value = 0 Then wa.Range("E" & r).EntireRow.Delete Shift:=xlUp
                    Next r
                    ws.Range("B" & s) = "Finished"
            End If
        Next s: wt.Visible = xlSheetHidden
        Application.ScreenUpdating = True
End Sub

BTW - You needn't change all the finished back to complete and delete all the sheets - just close it without saving and reopen it

Hi xladept,

Many thanks for this, yes it really does run much much faster... The issue with 'Template' being renamed 'Template2' is still there. I appreciate I could close the file without saving but it isn't designed to work like that. There will be times when the user runs the macro to create new sheets, then updates the summary sheet to find the next batch of complete schemes whilst needing to maintain the existing newly created sheets, closing without saving will lose those.

If you run macro, then manually change the status of some other schemes to complete on the Summary sheet and then run the macro a second time it will error. The sheet 'Template' needs to be hidden after running the macro, which is easy enough, I think a line possibly needs adding to rename 'Template2' back to 'Template' and then a line to hide it?

Many thanks

Maybe:

Sub Hangman(): Dim ws As Worksheet, wt As Worksheet, wa As Worksheet
                        Dim s As Long, r As Long
Set ws = Sheets("Summary"): Set wt = Sheets("Template")
wt.Visible = xlSheetVisible:                Application.ScreenUpdating = False
        For s = 2 To ws.Range("A" & Rows.count).End(xlUp).Row
            If ws.Range("B" & s) = "Complete" Then
        wt.Copy After:=Worksheets(Worksheets.count)
        Set wa = Worksheets(Worksheets.count): wa.Visible = xlSheetVisible
        wa.Name = ws.Range("A" & s): wa.Range("C5") = ws.Range("A" & s)
                    For r = 19 To 10 Step -1
If wa.Range("E" & r).Value = 0 Then wa.Range("E" & r).EntireRow.Delete Shift:=xlUp
                    Next r
                    ws.Range("B" & s) = "Finished"
            End If
        Next s:   Set wt = Nothing
        For Each wt In Worksheets
        If wt.Name Like "Template*" Then
        wt.Name = "Template": Exit For: End If
        Next: Set wt = Sheets("Template")
        wt.Visible = xlSheetHidden: Application.ScreenUpdating = True
End Sub