creating sheets from 3 columns of data. I may have gone slightly mad...

[jondallimore]

I have the code below, which creates sheets from a list of dates or names.

How would I modify it (or is it better to start again?) to produce sheets from a list of dates, but also to cross reference which DAY it is, and whether it is a week 1 or 2?

The date itself is contained in column A3 downwards.
The corresponding DAY will be in column B3 downwards.
Whether it is a week 1 or 2 will be in column C3 downwards. (the week numbers alternate).

I would like to have 10 templates, one for each monday to friday of weeks 1 and 2 (the weeks alternate), so that the code can copy the correct template for the week 1 or 2, and the day, and then name it with the date from column A.

I would also like it to ignore Saturday and Sunday, even though those days will have to be in the list.

Hopefully all that makes sense. Thankyou in advance for any help.
Jon

Private Sub CommandButton1_Click() Dim cell As Range, rnglist As Range
Dim ws As Worksheet
Set rnglist = Range("A3", Range("A" & Rows.Count).End(xlUp))
If Sheet2.Cells(3, 1) = "" Then
Sheet2.Activate
Cells(3, 1).Select
Application.DisplayAlerts = False
For Each ws In Worksheets
'Keep these non-list sheets
If InStr("|Navigation|Template|Instructions|", "|" & ws.name & "|") = 0 Then
'Test if each sheet is on the list
If WorksheetFunction.CountIf(rnglist, ws.name) = 0 Then ws.Delete
End If
Next ws
Application.DisplayAlerts = True
GoTo Skipout
Else:
GoTo Doit
End If
Doit:
Application.ScreenUpdating = False
For Each cell In rnglist
If cell.Value <> "" Then
On Error Resume Next
'test if worksheet exists
If Len(Worksheets(cell.Value).name) = 0 Then
On Error GoTo 0
'copy worksheet named "Template"
Worksheets("Template").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.name = cell.Value 'name new sheet
'Create hyperlink
Let x = "'" & cell.Value & "'!A1"
cell.Parent.hyperlinks.Add Anchor:=cell, _
Address:="", _
SubAddress:=x, _
TextToDisplay:=cell.Value

End If
On Error GoTo 0
End If
Next cell
CommandButton1.Parent.Activate 'go back to the source worksheet
'Delete "Other" Sheets not on the list
Application.DisplayAlerts = False
For Each ws In Worksheets
'Keep these non-list sheets
If InStr("|Navigation|Template|Instructions|", "|" & ws.name & "|") = 0 Then
'Test if each sheet is on the list
If WorksheetFunction.CountIf(rnglist, ws.name) = 0 Then ws.Delete
End If
Next ws
Application.DisplayAlerts = True
'FormulaeGeneration:
With Worksheets("Navigation").Range("C2:XFD2")
.Cells.AutoFill Destination:=.Cells.Resize(rnglist.Count + 1)
End With
'Formatting:
'clear all previous borders in columns A and B
With Range("A:B")
.borders(xlDiagonalDown).LineStyle = xlNone
.borders(xlDiagonalUp).LineStyle = xlNone
.borders(xlEdgeLeft).LineStyle = xlNone
.borders(xlEdgeTop).LineStyle = xlNone
.borders(xlEdgeBottom).LineStyle = xlNone
.borders(xlEdgeRight).LineStyle = xlNone
.borders(xlInsideVertical).LineStyle = xlNone
.borders(xlInsideHorizontal).LineStyle = xlNone
End With
'Add borders
With rnglist.Resize(, 2) 'list columns A and B
.borders(xlEdgeLeft).Weight = xlMedium
.borders(xlEdgeTop).Weight = xlMedium
.borders(xlEdgeBottom).Weight = xlMedium
.borders(xlEdgeRight).Weight = xlMedium
.borders(xlInsideVertical).Weight = xlThin
.borders(xlInsideHorizontal).Weight = xlThin
End With
Skipout:
Range("A2").Select
Selection.borders(xlDiagonalDown).LineStyle = xlNone
Selection.borders(xlDiagonalUp).LineStyle = xlNone
With Selection.borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.borders(xlInsideVertical).LineStyle = xlNone
Selection.borders(xlInsideHorizontal).LineStyle = xlNone
Range("B2").Select
Selection.borders(xlDiagonalDown).LineStyle = xlNone
Selection.borders(xlDiagonalUp).LineStyle = xlNone
With Selection.borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.borders(xlInsideVertical).LineStyle = xlNone
Selection.borders(xlInsideHorizontal).LineStyle = xlNone
Range("A3").Select


On Error Resume Next
Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0


If Sheet2.Cells(3, 1) = "" Then
MsgBox "You must enter Student Names in Column A"
End If
Application.ScreenUpdating = True

Break:
Application.ScreenUpdating = True
End Sub