jondallimore
09-08-2014, 12:32 PM
Hello,
I have the code below, which generates a set of worksheets from a list of dates using a template sheet.
However, I am looking to edit it... to do this:
1) select the right template to use based on the day in column E, and the week number in column G.
I.e. - 01.09.14 is a Monday of week 1, so that worksheet should be called 01.09.14 - which is already happening - and should be a copy of "Monday 1" template sheet.
2) there will be template sheets named Monday 1, tuesday 1, wednesday 1 , thursday 1, friday 1
AND the corresponding templates for week 2.
How can I make this code select the right template to use based on the values in columns E and G?
Thanks in advance for any help.
Jon
PS, I thought it better to put the entire code in... apologies for the long post.
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))
Set rngday = Range("E3", Range("E" & Rows.Count).End(xlUp))
Set rngweek = Range("G3", Range("G" & 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
Private Sub CommandButton2_Click()
Dim SNarray() As Variant
Dim i As Long
Dim s As Worksheet
i = 0
For Each s In ThisWorkbook.Sheets
Select Case s.name
Case Is = "Navigation", "Template"
'do nothing
Case Else
ReDim Preserve SNarray(i)
SNarray(i) = s.name
Debug.Print SNarray(i)
i = i + 1
End Select
Next
Dim arrSheets, sh As Worksheet
arrSheets = SNarray
If i = 0 Then
GoTo Ending
Else
Application.ScreenUpdating = False
Sheets(arrSheets).Select
For Each sh In ThisWorkbook.Windows(1).SelectedSheets
sh.PageSetup.PrintArea = ""
With sh.PageSetup
.Orientation = xlPortrait
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Next sh
Sheets(arrSheets).PrintPreview False
End If
GoTo Skippy
Ending:
MsgBox "There are no Marksheets to print"
Skippy:
Sheets("Navigation").Activate
Application.ScreenUpdating = True
End Sub
I have the code below, which generates a set of worksheets from a list of dates using a template sheet.
However, I am looking to edit it... to do this:
1) select the right template to use based on the day in column E, and the week number in column G.
I.e. - 01.09.14 is a Monday of week 1, so that worksheet should be called 01.09.14 - which is already happening - and should be a copy of "Monday 1" template sheet.
2) there will be template sheets named Monday 1, tuesday 1, wednesday 1 , thursday 1, friday 1
AND the corresponding templates for week 2.
How can I make this code select the right template to use based on the values in columns E and G?
Thanks in advance for any help.
Jon
PS, I thought it better to put the entire code in... apologies for the long post.
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))
Set rngday = Range("E3", Range("E" & Rows.Count).End(xlUp))
Set rngweek = Range("G3", Range("G" & 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
Private Sub CommandButton2_Click()
Dim SNarray() As Variant
Dim i As Long
Dim s As Worksheet
i = 0
For Each s In ThisWorkbook.Sheets
Select Case s.name
Case Is = "Navigation", "Template"
'do nothing
Case Else
ReDim Preserve SNarray(i)
SNarray(i) = s.name
Debug.Print SNarray(i)
i = i + 1
End Select
Next
Dim arrSheets, sh As Worksheet
arrSheets = SNarray
If i = 0 Then
GoTo Ending
Else
Application.ScreenUpdating = False
Sheets(arrSheets).Select
For Each sh In ThisWorkbook.Windows(1).SelectedSheets
sh.PageSetup.PrintArea = ""
With sh.PageSetup
.Orientation = xlPortrait
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Next sh
Sheets(arrSheets).PrintPreview False
End If
GoTo Skippy
Ending:
MsgBox "There are no Marksheets to print"
Skippy:
Sheets("Navigation").Activate
Application.ScreenUpdating = True
End Sub