VBA to create variable sheets and names

hblbs

Board Regular
Joined
Mar 18, 2009
Messages
184
Hi all, I am wondering if anyone has a VBA code to create sheets and copy rows of information over to the corresponding sheet. After Ma Base there is a blank column and the subject grades are listed, for each subject I need to create a sheet including all columns up to Ma Base and the subject and after the next break the subject class group. So in the example below there would be 3 sheets created (AR, BL and CP). Within each sheet the would be 10 records copied over for AR and CP and 3 for BL based on the results(4C).

[TABLE="width: 1547"]
<tbody>[TR]
[TD]StuId[/TD]
[TD]Student[/TD]
[TD]Class gp[/TD]
[TD]Sex[/TD]
[TD]GT[/TD]
[TD]Sub(s)[/TD]
[TD]S[/TD]
[TD]d(s)[/TD]
[TD]EL[/TD]
[TD]ligibility[/TD]
[TD]LAC[/TD]
[TD]Date of entry[/TD]
[TD]1st Yr[/TD]
[TD]Att %[/TD]
[TD]En Base[/TD]
[TD]Ma Base[/TD]
[TD][/TD]
[TD]AR Aut2: Year_9L[/TD]
[TD]BL Aut2: Year_9L[/TD]
[TD]CP Aut2: Year_9L[/TD]
[TD][/TD]
[TD]AR[/TD]
[TD]BL[/TD]
[TD]CP[/TD]
[/TR]
[TR]
[TD="align: right"]1[/TD]
[TD]A[/TD]
[TD]9MS[/TD]
[TD]M[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]04/09/2012[/TD]
[TD][/TD]
[TD="align: right"]97[/TD]
[TD]4b[/TD]
[TD]4c[/TD]
[TD][/TD]
[TD]5c[/TD]
[TD][/TD]
[TD]4b[/TD]
[TD][/TD]
[TD]9xAX4[/TD]
[TD][/TD]
[TD]9xCs4[/TD]
[/TR]
[TR]
[TD="align: right"]2[/TD]
[TD]B[/TD]
[TD]9IS[/TD]
[TD]M[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Y[/TD]
[TD][/TD]
[TD="align: right"]04/09/2012[/TD]
[TD][/TD]
[TD="align: right"]92[/TD]
[TD]4b[/TD]
[TD]4a[/TD]
[TD][/TD]
[TD]4a[/TD]
[TD][/TD]
[TD]5c[/TD]
[TD][/TD]
[TD]9yAX2[/TD]
[TD][/TD]
[TD]9yCs2[/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[TD]C[/TD]
[TD]9SM[/TD]
[TD]M[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Y[/TD]
[TD][/TD]
[TD="align: right"]04/09/2012[/TD]
[TD][/TD]
[TD="align: right"]88[/TD]
[TD]4b[/TD]
[TD]4a[/TD]
[TD][/TD]
[TD]4a[/TD]
[TD]4c[/TD]
[TD]5c[/TD]
[TD][/TD]
[TD]9xAX1[/TD]
[TD]9xBX[/TD]
[TD]9xCs1[/TD]
[/TR]
[TR]
[TD="align: right"]4[/TD]
[TD]D[/TD]
[TD]9IS[/TD]
[TD]F[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]EL[/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]30/04/2013[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]99[/TD]
[TD]3b[/TD]
[TD]3b[/TD]
[TD][/TD]
[TD]5c[/TD]
[TD]5b[/TD]
[TD]3a[/TD]
[TD][/TD]
[TD]9yAX4[/TD]
[TD]9yBX[/TD]
[TD]9yCs4[/TD]
[/TR]
[TR]
[TD="align: right"]5[/TD]
[TD]E[/TD]
[TD]9qN[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]Gg,It,Ma,Re[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]04/09/2012[/TD]
[TD][/TD]
[TD="align: right"]97[/TD]
[TD]5a[/TD]
[TD]5a[/TD]
[TD][/TD]
[TD]5b[/TD]
[TD][/TD]
[TD]5a[/TD]
[TD][/TD]
[TD]9yAX3[/TD]
[TD][/TD]
[TD]9yCs3[/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD]F[/TD]
[TD]9qN[/TD]
[TD]M[/TD]
[TD][/TD]
[TD][/TD]
[TD]K[/TD]
[TD="colspan: 2"]MLD,SLCN[/TD]
[TD]Y[/TD]
[TD][/TD]
[TD="align: right"]04/09/2012[/TD]
[TD][/TD]
[TD="align: right"]95[/TD]
[TD]3b[/TD]
[TD]4c[/TD]
[TD][/TD]
[TD]5c[/TD]
[TD][/TD]
[TD]4c[/TD]
[TD][/TD]
[TD]9yAX5[/TD]
[TD][/TD]
[TD]9yCs5[/TD]
[/TR]
[TR]
[TD="align: right"]7[/TD]
[TD]G[/TD]
[TD]9Ru[/TD]
[TD]M[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Y[/TD]
[TD][/TD]
[TD="align: right"]04/09/2012[/TD]
[TD][/TD]
[TD="align: right"]93[/TD]
[TD]5c[/TD]
[TD]4b[/TD]
[TD][/TD]
[TD]4a[/TD]
[TD][/TD]
[TD]5b[/TD]
[TD][/TD]
[TD]9xAX2[/TD]
[TD][/TD]
[TD]9xCs2[/TD]
[/TR]
[TR]
[TD="align: right"]8[/TD]
[TD]H[/TD]
[TD]9KE[/TD]
[TD]M[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]04/09/2012[/TD]
[TD][/TD]
[TD="align: right"]94[/TD]
[TD]4a[/TD]
[TD]4b[/TD]
[TD][/TD]
[TD]4a[/TD]
[TD]5c[/TD]
[TD]4a[/TD]
[TD][/TD]
[TD]9yAX2[/TD]
[TD]9yBX[/TD]
[TD]9yCs2[/TD]
[/TR]
[TR]
[TD="align: right"]9[/TD]
[TD]I[/TD]
[TD]9IS[/TD]
[TD]M[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Y[/TD]
[TD][/TD]
[TD="align: right"]04/09/2012[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]98[/TD]
[TD]4b[/TD]
[TD]4b[/TD]
[TD][/TD]
[TD]5c[/TD]
[TD][/TD]
[TD]4b[/TD]
[TD][/TD]
[TD]9yAX5[/TD]
[TD][/TD]
[TD]9yCs5[/TD]
[/TR]
[TR]
[TD="align: right"]10[/TD]
[TD]J[/TD]
[TD]9qz[/TD]
[TD]M[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]04/09/2013[/TD]
[TD][/TD]
[TD="align: right"]98[/TD]
[TD]4b[/TD]
[TD]4c[/TD]
[TD][/TD]
[TD]4b[/TD]
[TD][/TD]
[TD]4a[/TD]
[TD][/TD]
[TD]9xAX2[/TD]
[TD][/TD]
[TD]9xCs2[/TD]
[/TR]
</tbody>[/TABLE]

I could of course copy the sheets 3 times and the filter and delete the necessary columns and rows, however I have to to this with over 20 subjects of various class sizes and it would be useful if this could be automated as it is needs to be done fairly regularly for 5 year groups and 20 subjects(5*20=100 sheets to create and amend).

Thanks in advance.
 
I have tried amending the following which creates a list based on rows in a sheet, but was wondering if anyone knows how to amend so that it can be used to work across columns like my scenario above.

Code:
Sub createShts()
Dim rData As Range
    Dim rCl As Range
    Dim sNm As String
    
    Set ws = Sheet1
    'extract a list of unique names
    'first clear existing list
    With ws
        Set rData = .Range(.Cells(1, 1), .Cells(Rows.Count, 3).End(xlUp))
        .Columns(256).Clear
        .Range(Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, 256), Unique:=True
    
        For Each rCl In .Range(.Cells(1, 256), .Cells(.Rows.Count, 256).End(xlUp))
            sNm = rCl.Text
            'add new sheet (only if required-NB uses UDF)
            If WksExists(sNm) Then
                'so clear contents
                Sheets(sNm).Cells.Clear
            Else
                'new sheet required
                Set wsNew = Sheets.Add
                wsNew.Move After:=Worksheets(Worksheets.Count) 'move to end
                wsNew.Name = sNm
            End If
            'AutoFilter & copy to relevant sheet
            rData.AutoFilter Field:=1, Criteria1:=sNm
            rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
        Next rCl
        End With
        ws.Columns(256).ClearContents 'remove temporary list
        rData.AutoFilter 'switch off AutoFilter
    End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top