Hi all,
I have inherited this spreadsheet. On sheet 1 i can create times from B11 down eg 08:45 08:49 etc. The problem is i can have all the time stored on the data sheet but when i recall the times to show on sheet 1 it stops at cell B60. I have looked at the code and changed anything that had 60 to 70 but it still stops at 60. Hope this makes sense. I have attached the code below. Sorry for so much code. Thanks in advance.
Red
Private Sub clear_screen() 'Clear screen
Sheets("sheet1").Unprotect Password:="XXXXXXXX"
Sheets("data").Unprotect Password:="XXXXXXXX"
Cells(1, 18) = 0 'Cell R1
Range("L11:l70").Select
With Selection.Interior
.ColorIndex = 2
End With
' Clear all contents
Range("b11:b70").ClearContents
Range("h11:h70").ClearContents
Range("n11:n70").ClearContents
Range("d11:d70").ClearContents
Range("f11:f70").ClearContents
Range("h11:h70").ClearContents
Range("j11:j70").ClearContents
Range("l11:l70").ClearContents
Range("l11:l70").Select
Selection.Interior.ColorIndex = xlNone
Range("m11:m70").ClearContents
Range("n11:n70").ClearContents
Range("p11
70").ClearContents
Range("r11:r70").ClearContents
Range("b11:b70").ClearContents
Range("s11:s70").ClearContents
Range("m11:m70").ClearContents
Range("w11:w70").ClearContents
Range("t11:t70").ClearContents
Range("v11:v70").ClearContents
Range("w11:w70").ClearContents
Range("x11:x70").ClearContents
Range("y11:y70").ClearContents
Range("z11:z70").ClearContents
Range("aa11:aa70").ClearContents
Range("ab11:ab70").ClearContents
Range("ac11:ac70").ClearContents
Range("ad11:ad70").ClearContents
Range("t11:t70").Select
Selection.Interior.ColorIndex = xlNone
Range("D11:D70,F11:F70,H11:H70,J11:J70,B11:B70").Select
Range("B11").Activate
Selection.Locked = False
Selection.FormulaHidden = False
Cells(5, 14) = "" 'box count blank
Cells(5, 8) = "" 'day cycle blank
Range("d11:d70").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Cells(11, 4).Select
Cells(5, 14).Select
Selection.Locked = False
Sheets("sheet1").Protect Password:="XXXXXXXX"
Sheets("data").Protect Password:="XXXXXXXX"
End Sub
Private Sub CommandButton1_Click() 'Initial setup
Dim a, c, d, e, f As String
Dim b As Date
Dim i As Long
d = Sheets("lists").Cells(16, 1) 'Office name
Sheets("sheet1").Unprotect Password:="XXXXXXXX"
Sheets("data").Unprotect Password:="XXXXXXXX"
' Display message if currently has records on screen
If Cells(1, 18) = 1 Then 'Checking value cell R1 - has value 1 if records on screen
i = MsgBox("The record on screen has not been saved! Do you wish to continue?", vbYesNo, d)
If i <> 6 Then
Sheets("sheet1").Protect Password:="XXXXXXXX"
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
Else
Call clear_screen
End If
End If
a = InputBox("Please input password", d)
'Checking correct password
If a <> " XXXXXXXX " Then
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
'Need to have day/cycle selected to do initial set up
If Cells(5, 14) = "" Then
MsgBox "No Cycle/Signing Day information recorded. Please correct before proceeding!", vbInformation, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
Cells(1, 1).Select
Range("b11").ClearContents
c = InputBox("Please input the initial start time. Format should be hh:mm", d)
mycheck = c 'initial start time
If IsDate(mycheck) = False Then 'Must be valid time
MsgBox "Invalid start time entered. Please re-run set up", vbOKOnly, d
Range("d11:d70").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
c = FormatDateTime(c, vbShortTime)
'Call clear_screen
Cells(11, 2) = c 'put start time in cell B11
Range("d11:d70").Select 'Nino
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$w$1:$w$4"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
For j = 12 To 64
If Cells(j - 1, 2) = Cells(3, 1) Then
Exit For
End If
Cells(j, 2) = Cells(j - 1, 2) + Cells(2, 1) 'set up signing times according to time in A2 till A3 end time
Next j
Cells(11, 4).Select 'Nino
MsgBox "Please input Tea/Lunch breaks etc", vbOKOnly, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
End Sub
Private Sub CommandButton10_Click() 'Print specific month
Dim b As String
Dim a, d As String
Dim i, j As Long
d = Sheets("lists").Cells(16, 1)
' clears the archive sheet ready for populating
Sheets("archive").Select
Sheets("archive").Range("A1:N1000").Select
Selection.ClearContents
'asks the user for the month they wish to print and whether it is all cases or just the outstanding.
a = InputBox("Please input the Month you wish to view in the following format 01/mm/yyyy.", d)
If IsDate(a) = False Then
MsgBox "Invalid date entered, please try again", vbExclamation, d
Exit Sub
End If
b = InputBox("Do you wish to view all cases received in month or just the outstanding?. Enter 1 for all cases and 2 for only the outstanding.", d)
If b <> "1" And b <> "2" Then
MsgBox "Invalid entry, 1 0r 2 must be entered", vbExclamation, d
Exit Sub
End If
i = 5 'Holds current row being looked at in data sheet
j = 2 'Holds row being written to in archive sheet. Starts under headings
c = Month(a) 'Month input by user
d = Year(a) 'Year input by user
'Set up headers in archive sheet
Sheets("archive").Cells(1, 1) = "Part1"
Sheets("archive").Cells(1, 2) = "Part2"
Sheets("archive").Cells(1, 3) = "Part3"
Sheets("archive").Cells(1, 4) = "Part4"
Sheets("archive").Cells(1, 5) = "Initial"
Sheets("archive").Cells(1, 6) = "Part5"
Sheets("archive").Cells(1, 7) = "Part6"
Sheets("archive").Cells(1, 8) = "Part7"
Sheets("archive").Cells(1, 9) = "Part8"
Sheets("archive").Cells(1, 10) = "Part 9"
Sheets("archive").Cells(1, 11) = "Part10"
Sheets("archive").Cells(1, 12) = "Part11"
Sheets("archive").Cells(1, 13) = "Part 12"
Sheets("archive").Cells(1, 14) = "Part 13"
'Do Until all records have been checked through
Do Until Sheets("data").Cells(i, 1) = ""
'If record matches month/year input by user
If d = Year(Sheets("data").Cells(i, 7)) And c = Month(Sheets("data").Cells(i, 7)) Then
'Continue search from next row if user has selected outstanding cases only and LED completed
If b = 2 And Sheets("data").Cells(i, 9) <> "" Then
GoTo continuesearch
End If
' Populate archive sheet
Sheets("archive").Cells(j, 1) = Sheets("data").Cells(i, 8)
Sheets("archive").Cells(j, 2) = Sheets("data").Cells(i, 2)
Sheets("archive").Cells(j, 3) = Sheets("data").Cells(i, 3)
Sheets("archive").Cells(j, 4) = Sheets("data").Cells(i, 4)
Sheets("archive").Cells(j, 5) = Sheets("data").Cells(i, 5)
Sheets("archive").Cells(j, 6) = Sheets("data").Cells(i, 7)
Sheets("archive").Cells(j, 7) = Sheets("data").Cells(i, 18)
Sheets("archive").Cells(j, 8) = Sheets("data").Cells(i, 19)
Sheets("archive").Cells(j, 9) = Sheets("data").Cells(i, 20)
Sheets("archive").Cells(j, 10) = Sheets("data").Cells(i, 21)
Sheets("archive").Cells(j, 11) = Sheets("data").Cells(i, 24)
Sheets("archive").Cells(j, 12) = Sheets("data").Cells(i, 23)
Sheets("archive").Cells(j, 13) = Sheets("data").Cells(i, 9)
Sheets("archive").Cells(j, 14) = Sheets("data").Cells(i, 10)
'Add one to count of rows
j = j + 1
End If
continuesearch:
'Add one to data sheet row to look at next row on next repetion of loop
i = i + 1
Loop
End Sub
Private Sub CommandButton11_Click() 'Remove old cases - over 13 months
Dim i As Long
Dim d As String
d = Sheets("lists").Cells(16, 1) 'd=Office name
Sheets("data").Unprotect Password:=" XXXXXXXX "
Sheets("data").Select
i = 5
Do Until Sheets("data").Cells(i, 2) = "" ' do until end of data
If Sheets("data").Cells(i, 9) <> "" Then ' If LED completed
If DateAdd("m", 13, Sheets("data").Cells(i, 9)) <= Date Then 'if older than 13 months
Sheets("data").Rows(i).Delete 'delete row from spreadsheet
i = i - 1
End If
End If
i = i + 1
Loop
Sheets("data").Unprotect Password:=" XXXXXXXX "
Sheets("Sheet1").Select
End Sub
Private Sub CommandButton12_Click() 'List search - leaves info in the archive tab
Dim b, d As String
Dim a As String
Dim i, j As Long
d = Sheets("lists").Cells(16, 1)
' clears the archive sheet ready for populating
Sheets("archive").Select
Sheets("archive").Range("A1:N1000").Select
Selection.ClearContents
a = InputBox("Please enter the List code. ")
i = 5 'counter for rows on data tab
j = 2 'counter for rows on archive tab
' Set up archive sheet headings
Sheets("archive").Cells(1, 1) = "Part1"
Sheets("archive").Cells(1, 2) = "Part2"
Sheets("archive").Cells(1, 3) = "Part3"
Sheets("archive").Cells(1, 4) = "Part4"
Sheets("archive").Cells(1, 5) = "Part5"
Sheets("archive").Cells(1, 6) = "Part6"
Sheets("archive").Cells(1, 7) = "Part7"
Sheets("archive").Cells(1, 8) = "Part 8"
Sheets("archive").Cells(1, 9) = "Part9"
Sheets("archive").Cells(1, 10) = "Part10"
Sheets("archive").Cells(1, 11) = "Part11"
Sheets("archive").Cells(1, 12) = "Part 12"
Sheets("archive").Cells(1, 13) = "Part13"
Do Until Sheets("data").Cells(i, 1) = ""
If Sheets("data").Cells(i, 9) = "" Then 'Where live
If Sheets("data").Cells(i, 19) = a Then 'search column S List code
Sheets("archive").Cells(j, 1) = Sheets("data").Cells(i, 8)
Sheets("archive").Cells(j, 2) = Sheets("data").Cells(i, 2)
Sheets("archive").Cells(j, 3) = Sheets("data").Cells(i, 3)
Sheets("archive").Cells(j, 4) = Sheets("data").Cells(i, 4)
Sheets("archive").Cells(j, 5) = Sheets("data").Cells(i, 5)
Sheets("archive").Cells(j, 6) = Sheets("data").Cells(i, 7)
Sheets("archive").Cells(j, 7) = Sheets("data").Cells(i, 18)
Sheets("archive").Cells(j, 8) = Sheets("data").Cells(i, 19)
Sheets("archive").Cells(j, 9) = Sheets("data").Cells(i, 20)
Sheets("archive").Cells(j, 10) = Sheets("data").Cells(i, 21)
Sheets("archive").Cells(j, 11) = Sheets("data").Cells(i, 24)
Sheets("archive").Cells(j, 12) = Sheets("data").Cells(i, 23)
Sheets("archive").Cells(j, 13) = Sheets("data").Cells(i, 23)
j = j + 1
End If
If Sheets("data").Cells(i, 20) = a Then 'search column T List code
Sheets("archive").Cells(j, 1) = Sheets("data").Cells(i, 8)
Sheets("archive").Cells(j, 2) = Sheets("data").Cells(i, 2)
Sheets("archive").Cells(j, 3) = Sheets("data").Cells(i, 3)
Sheets("archive").Cells(j, 4) = Sheets("data").Cells(i, 4)
Sheets("archive").Cells(j, 5) = Sheets("data").Cells(i, 5)
Sheets("archive").Cells(j, 6) = Sheets("data").Cells(i, 7)
Sheets("archive").Cells(j, 7) = Sheets("data").Cells(i, 18)
Sheets("archive").Cells(j, 8) = Sheets("data").Cells(i, 19)
Sheets("archive").Cells(j, 9) = Sheets("data").Cells(i, 20)
Sheets("archive").Cells(j, 10) = Sheets("data").Cells(i, 21)
Sheets("archive").Cells(j, 11) = Sheets("data").Cells(i, 24)
Sheets("archive").Cells(j, 12) = Sheets("data").Cells(i, 23)
j = j + 1
End If
If Sheets("data").Cells(i, 21) = a Then 'search column U List code
Sheets("archive").Cells(j, 1) = Sheets("data").Cells(i, 8)
Sheets("archive").Cells(j, 2) = Sheets("data").Cells(i, 2)
Sheets("archive").Cells(j, 3) = Sheets("data").Cells(i, 3)
Sheets("archive").Cells(j, 4) = Sheets("data").Cells(i, 4)
Sheets("archive").Cells(j, 5) = Sheets("data").Cells(i, 5)
Sheets("archive").Cells(j, 6) = Sheets("data").Cells(i, 7)
Sheets("archive").Cells(j, 7) = Sheets("data").Cells(i, 18)
Sheets("archive").Cells(j, 8) = Sheets("data").Cells(i, 19)
Sheets("archive").Cells(j, 9) = Sheets("data").Cells(i, 20)
Sheets("archive").Cells(j, 10) = Sheets("data").Cells(i, 21)
Sheets("archive").Cells(j, 11) = Sheets("data").Cells(i, 24)
Sheets("archive").Cells(j, 12) = Sheets("data").Cells(i, 23)
j = j + 1
End If
End If
i = i + 1 'Move onto next row
Loop
Sheets("archive").Select
End Sub
Private Sub CommandButton2_Click() 'Save initial setup
Dim i As Long
Dim d As String
d = Sheets("lists").Cells(16, 1) 'Office
Sheets("sheet1").Unprotect Password:=" XXXXXXXX "
Sheets("data").Unprotect Password:=" XXXXXXXX "
'Checks that information has been entered
If Cells(11, 2) = "" Then
MsgBox "No records to save!", vbExclamation, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
i = 5 'counter for data sheet row
Do Until Sheets("data").Cells(i, 2) = ""
i = i + 1
'Checks if day already set up
If Sheets("data").Cells(i, 8) = Cells(5, 14) Then
MsgBox "Records already held for this Day. Please use the recall method to view the data.", vbOKOnly, d
Call clear_screen
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
Loop
'Saves new set up
For j = 11 To 70
If Cells(j, 2) = "" Then
Exit For
Else
Sheets("data").Cells(i, 1) = Cells(j, 1)
Sheets("data").Cells(i, 2) = Cells(j, 2)
Sheets("data").Cells(i, 3) = Cells(j, 4)
Sheets("data").Cells(i, 8) = Cells(5, 14)
Sheets("data").Cells(i, 15) = Cells(3, 14)
Sheets("data").Cells(i, 17) = Cells(3, 6)
i = i + 1
End If
Next j
MsgBox "Records Saved", vbOKOnly, d
Call clear_screen
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
End Sub
Private Sub CommandButton3_Click() 'Recall records
Dim i, j, k, m As Long
Dim d As String
d = Sheets("lists").Cells(16, 1) 'name
Sheets("sheet1").Unprotect Password:=" XXXXXXXX "
Sheets("data").Unprotect Password:=" XXXXXXXX "
' Must update records on screen before can select a new day
If Cells(1, 18) = 1 Then
m = MsgBox("The records on screen have not been updated. Do you wish to continue without saving?", vbYesNo, d)
If m = 6 Then
Call clear_screen
Else
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
End If
'Must select a cycle to recall
If Cells(5, 14) = "" Then
MsgBox "No Day selected!", vbExclamation, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
i = 5 'counter for row in data sheet
k = 0
Do Until Sheets("data").Cells(i, 2) = ""
Call check_recs(i, k) 'Pull back records from data sheet
i = i + 1 'Go to next record
Loop
'Format records
Call format_recs
Cells(1, 1).Select
Cells(1, 18) = 1
Cells(5, 14).Select
Selection.Locked = True
MsgBox "Records ready for update", vbOKOnly, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
End Sub
' Uses colour format - IDOC will turn amber within 6 weeks of a key date, and red within 4
' weeks of key date. Also colours the stage they are at within their claim
Private Sub format_recs()
Dim a As Double
Dim i, j As Long
Dim d As String
d = Sheets("lists").Cells(16, 1) 'office name
For i = 11 To 70
'Works out claim stage and appropriate colour
If Cells(i, 12) <> "" Then 'if IDOC not blank
a = DateDiff("d", Cells(i, 12), Now) 'days between now and IDOC
a = a / 7 'claim week
If a <= 13 Then
Cells(i, 20) = "13 Week"
Cells(i, 20).Select
Selection.Interior.ColorIndex = 50
ElseIf a > 13 And a <= 26 Then
Cells(i, 20) = "26 Week"
Cells(i, 20).Select
Selection.Interior.ColorIndex = 6
ElseIf a > 26 And a <= 39 Then
Cells(i, 20) = "39 Week"
Cells(i, 20).Select
Selection.Interior.ColorIndex = 44
ElseIf a > 39 And a <= 52 Then
Cells(i, 20) = "52 Week"
Cells(i, 20).Select
Selection.Interior.ColorIndex = 3
ElseIf a > 52 Then
Cells(i, 20) = "Over 52"
End If
'Set amber if within 4-6 weeks of a trigger date
If a >= 7 And a < 9 Or a >= 20 And a < 22 Or a >= 33 And a < 35 Or a >= 46 And a < 48 Then
Cells(i, 12).Select
Selection.Interior.ColorIndex = 44
End If
'Set red if within 4 weeks of a trigger date
If a >= 9 And a < 13 Or a >= 22 And a < 26 Or a >= 35 And a < 39 Or a >= 48 And a < 52 Then
Cells(i, 12).Select
Selection.Interior.ColorIndex = 3
End If
End If
Next i 'move to new row
End Sub
Private Sub check_recs(i, k) 'Pull back records from data sheet
Dim j As Long
Dim d As String
d = Sheets("lists").Cells(16, 1) 'office name
' Check for box name and cycle matching information selected by user
If Sheets("data").Cells(i, 17) = Cells(3, 6) And Sheets("data").Cells(i, 8) = Cells(5, 14) Then
For j = 11 To 60
If Cells(j, 1) = Sheets("data").Cells(i, 1) And Sheets("data").Cells(i, 9) = "" Then 'if still Testing
Cells(j, 1) = Sheets("data").Cells(i, 1) 'row number (not displayed)
Cells(j, 2) = Sheets("data").Cells(i, 2) 'time
Cells(j, 4) = Sheets("data").Cells(i, 3) 'nino
If Cells(j, 4) <> "" Then 'Part entered
Cells(j, 4).Select 'Part can't be updated/overwritten to prevent errors
Selection.Locked = True
End If
Cells(j, 6) = Sheets("data").Cells(i, 4) 'surname
If Cells(j, 6) <> "" Then 'Surname can't be updated/overwritten
Cells(j, 6).Select
Selection.Locked = True
End If
Cells(j, 8) = Sheets("data").Cells(i, 5) 'initial
If Cells(j, 8) <> "" Then 'Initial can't be updated/overwritten
Cells(j, 8).Select
Selection.Locked = True
End If
'All of the below can be updated by adviser/assistant adviser if necessary
Cells(j, 10) = Sheets("data").Cells(i, 6) 'Part1
Cells(j, 12) = Sheets("data").Cells(i, 7) 'Part2
Cells(j, 13) = Sheets("data").Cells(i, 18) 'Part3
Cells(j, 14) = Sheets("data").Cells(i, 9) 'Part4
Cells(j, 16) = Sheets("data").Cells(i, 10) 'Part5
Cells(j, 18) = Sheets("data").Cells(i, 16) 'Part6.
Cells(j, 22) = Sheets("data").Cells(i, 19) 'Part7
Cells(j, 23) = Sheets("data").Cells(i, 20) 'Part8
Cells(j, 24) = Sheets("data").Cells(i, 21) 'Part9
Cells(j, 26) = Sheets("data").Cells(i, 22) 'Part10
Cells(j, 27) = Sheets("data").Cells(i, 23) 'Part11
Cells(j, 28) = Sheets("data").Cells(i, 24) 'Part 12
Cells(j, 29) = Sheets("data").Cells(i, 25) 'Part13
Cells(j, 30) = Sheets("data").Cells(i, 26) 'Part14
If Sheets("data").Cells(i, 4) <> "" And Sheets("data").Cells(i, 9) = "" Then
Cells(5, 8) = Cells(5, 8) + 1 'update box count for live records
End If
Cells(j, 19) = i 'row number held in column s for use when records updated later
End If
Next j
End If
End Sub
Private Sub check_reason(a) 'Checks that both Part5& Part6 are recorded if one is
Dim j As Long
Dim b, c, f As String
Dim d, e As Date
f = Sheets("lists").Cells(16, 1) 'Office name
a = 0
'Search through all records on screen
For j = 11 To 70
'If time blank, reached end of signing slots so exit subroutine
If Cells(j, 2) = "" Then
Exit Sub
End If
'Checks if LED completed without a reason. User cannot proceed with update until corrected
If Cells(j, 14) <> "" And Cells(j, 16) = "" Then
c = Cells(j, 8) + " " + Cells(j, 6)
b = "Last effective date recorded for " + c + " but no reason recorded. please correct before proceeding!"
MsgBox b, vbOKOnly, f
a = 1
Exit Sub
End If
'Checks if off flow reason has been recorded without a date. User cannot proceed with update until corrected.
If Cells(j, 16) <> "" And Cells(j, 14) = "" Then
c = Cells(j, 8) + " " + Cells(j, 6)
b = "Off flow reason recorded for " + c + " but no date recorded. please correct before proceeding!"
MsgBox b, vbOKOnly, f
a = 1
Exit Sub
End If
Next j
End Sub
Private Sub check_date(b) 'Checks dates entered are valid
Dim i As Integer
Dim c, d As String
d = Sheets("lists").Cells(16, 1) 'office name
'Searches through all data on sheet
For i = 11 To 70
'If LED has been input, checks it is a valid date. User must correct before records can be updated
If Cells(i, 14) <> "" Then
mycheck = IsDate(Cells(i, 14))
If mycheck = False Then
b = 1
c = "Incorrect last effective date input for " + Cells(i, 8) + " " + Cells(i, 6) + ". Please correct before proceeding"
MsgBox c
Exit Sub
End If
End If
'If Part1 has been input, checks it is a valid date. User must correct before records can be updated
If Cells(i, 10) <> "" Then
mycheck = IsDate(Cells(i, 10))
If mycheck = False Then
b = 1
c = "Incorrect date of birth input for " + Cells(i, 8) + " " + Cells(i, 6) + ". Please correct before proceeding"
MsgBox c
Exit Sub
End If
End If
'If Part7 has been input, checks it is a valid date. User must correct before records can be updated
If Cells(i, 12) <> "" Then
mycheck = IsDate(Cells(i, 12))
If mycheck = False Then
b = 1
c = "Incorrect date of IDOC input for " + Cells(i, 8) + " " + Cells(i, 6) + ". Please correct before proceeding"
MsgBox c
Exit Sub
End If
End If
Next i
End Sub
Private Sub CommandButton4_Click() 'Update records
Dim i, j, k, l As Long
Dim a, b As Integer
Dim d As String
Dim date1, date2 As Date
d = Sheets("lists").Cells(16, 1) 'd = 'Office Name
Sheets("sheet1").Unprotect Password:=" XXXXXXXX "
Sheets("data").Unprotect Password:=" XXXXXXXX "
'Checks that records are displayed on screen to update
If Cells(11, 2) = "" Then
MsgBox "No records to update!", vbExclamation, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
b = 0
Call check_date(b) 'checking valid LED dates entered
If b = 1 Then
Exit Sub
End If
Call check_reason(a) 'Check if Part3, reason recorded & vice versa
If a = 1 Then
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
'Displays warning message if sheet opened in read only
If ActiveWorkbook.ReadOnly Then
MsgBox "You do not have full access to the spreadsheet at this time. Changes will NOT be saved.", vbExclamation, d
Exit Sub
End If
i = 5
Do Until Sheets("data").Cells(i, 2) = "" 'count of number of slots
i = i + 1
Loop
'Check all data on sheet
For j = 11 To 70
If Cells(j, 2) = "" Then
Exit For
Else
'Updates each row on the data sheet with information held/input on main sheet.
If Cells(j, 19) <> "" Then 'when col S not blank (original row number held here)
k = Cells(j, 19) ' row on data sheet that record relates to
Sheets("data").Cells(k, 1) = Cells(j, 1) ' Part1
Sheets("data").Cells(k, 2) = Cells(j, 2) ' Part2
Sheets("data").Cells(k, 3) = UCase(Cells(j, 4)) ' Part3
Sheets("data").Cells(k, 4) = UCase(Cells(j, 6)) ' Part4
Sheets("data").Cells(k, 5) = UCase(Cells(j, 8)) ' Part5
Sheets("data").Cells(k, 6) = Cells(j, 10) ' Part6
Sheets("data").Cells(k, 7) = Cells(j, 12) ' Part7
Sheets("data").Cells(k, 8) = Cells(5, 14) ' Part8
Sheets("data").Cells(k, 18) = Cells(j, 13) ' Part9
Sheets("data").Cells(k, 19) = Cells(j, 22) ' Part10
Sheets("data").Cells(k, 20) = Cells(j, 23) ' Part11
Sheets("data").Cells(k, 21) = Cells(j, 24) ' Part 12
Sheets("data").Cells(k, 22) = Cells(j, 26) ' Part 13
Sheets("data").Cells(k, 23) = Cells(j, 27) ' Part 14
Sheets("data").Cells(k, 24) = Cells(j, 28) ' Part 15
Sheets("data").Cells(k, 25) = Cells(j, 29) ' Part 16
Sheets("data").Cells(k, 26) = Cells(j, 30) ' Part 17
Sheets("data").Cells(k, 9) = Cells(j, 14) 'Part 18
'Works out which on flow cohort the claimant belongs to
If Sheets("data").Cells(k, 27) = "" Then 'If Cohort not completed
CohortCount = 1 'counts rows on cohorts so that checks until end. New cohorts can be added
Do Until Sheets("Cohorts").Cells(CohortCount, 1) = "" 'Do Until checked all cohorts
If Sheets("data").Cells(k, 7) >= (Sheets("Cohorts").Cells(CohortCount, 1)) And Sheets("data").Cells(k, 7) <= Sheets("Cohorts").Cells(CohortCount, 2) Then
Cohort = Sheets("Cohorts").Cells(CohortCount, 3)
Sheets("data").Cells(k, 27) = Cohort
End If
CohortCount = CohortCount + 1
Loop
End If
'if LED is completed create new record on data sheet for populating & update off flow cohort
If Cells(j, 14) <> "" Then
Sheets("data").Cells(i, 1) = Cells(j, 1) ' Part1
Sheets("data").Cells(i, 2) = Cells(j, 2) ' Part2
Sheets("data").Cells(i, 8) = Cells(5, 14) ' Part3
Sheets("data").Cells(i, 15) = Cells(3, 14) ' Part4
Sheets("data").Cells(i, 17) = Cells(3, 6) ' Part5
i = i + 1
'Update data sheet to show which stage claimant off flowed at
If Cells(j, 16) = "Part1" Or Cells(j, 16) = "Part2" Or Cells(j, 16) = "Part3" _
Or Cells(j, 16) = "Part4" Or Cells(j, 16) = "Part5" Then
date1 = Sheets("data").Cells(k, 7) 'Part6
date2 = Sheets("data").Cells(k, 9) 'Part7
If DateDiff("d", date1, date2) <= 91 Then 'Part9
Sheets("data").Cells(k, 11) = 1
ElseIf DateDiff("d", date1, date2) > 91 And DateDiff("d", date1, date2) <= 182 Then 'Part11
Sheets("data").Cells(k, 12) = 1
ElseIf DateDiff("d", date1, date2) > 182 And DateDiff("d", date1, date2) <= 273 Then 'Part14
Sheets("data").Cells(k, 13) = 1
ElseIf DateDiff("d", date1, date2) > 273 And DateDiff("d", date1, date2) <= 364 Then 'Part16
Sheets("data").Cells(k, 14) = 1
End If
End If
End If
'Calculate off flow cohort
If Cells(j, 14) <> "" And Sheets("data").Cells(k, 28) = "" Then 'If LED entered and cohort not completed
OffCount = 1 'counts rows on cohorts so that checks until end. New cohorts can be added
Do Until Sheets("Cohorts").Cells(OffCount, 1) = "" 'Do Until checked all cohorts
If Sheets("data").Cells(k, 9) >= (Sheets("Cohorts").Cells(OffCount, 1)) And Sheets("data").Cells(k, 7) <= Sheets("Cohorts").Cells(OffCount, 2) Then
OffCohort = Sheets("Cohorts").Cells(OffCount, 3)
Sheets("data").Cells(k, 28) = OffCohort
End If
OffCount = OffCount + 1
Loop
End If
'Update remainder of information in data tab
Sheets("data").Cells(k, 10) = Cells(j, 16) ' Part1
Sheets("data").Cells(k, 15) = Cells(3, 14) ' Part2
Sheets("data").Cells(k, 16) = Cells(j, 18) ' Part3
Sheets("data").Cells(k, 17) = Cells(3, 6) ' Part4
End If
End If
Next j
'Advise user that records have been updated and save spreadsheet
MsgBox "Records Updated", vbOKOnly, d
Call clear_screen
ActiveWorkbook.Save
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
End Sub
Private Sub CommandButton5_Click() 'Exit (runs stats on exit)
Dim a As Integer
Dim d As String
d = Sheets("lists").Cells(16, 1) 'Office name
' Checks if records have been saved before allowing user to exit
If Cells(1, 18) = 1 Then
a = MsgBox("The record on screen has not been saved do you wish to save and exit now?", vbYesNo, d)
If a = 6 Then 'If yes to save
Call CommandButton4_Click
Call run_stats
ActiveWorkbook.Close SaveChanges:=True
End If
Else
Call run_stats
ActiveWorkbook.Close SaveChanges:=True
End If
End Sub
Private Sub CommandButton6_Click() 'Clear screen functionality - not currently used
Dim i As Integer
Dim d As String
d = Sheets("lists").Cells(16, 1)
'Checks if user wishes to continue as clear screen does not save any updates
If Cells(1, 18) = 1 Then
i = MsgBox("The record on screen has not been saved! Do you wish to continue?", vbYesNo, d)
If i <> 6 Then
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
Else
Call clear_screen
End If
End If
Call clear_screen
End Sub
Private Sub run_stats() 'Called when exit button is used to update stats worksheet
Dim i, j As Long
Dim date1, date2 As Date
Dim a, b, c, d, e, f, p, q, aa, bb, cc, dd, ee, ff, gg, hh, ii, jj, kk, ll, mm, temp1, zz As Long
Dim check1 As String
Dim xx As Double
' Displays error message if user has no data in spreadsheet
If Sheets("data").Cells(5, 2) = "" Then
MsgBox "No data recorded", vbOKOnly, "Office Name"
Exit Sub
End If
Sheets("sheet1").Unprotect Password:=" XXXXXXXX "
Sheets("data").Unprotect Password:=" XXXXXXXX "
Sheets("stats").Unprotect Password:=" XXXXXXXX "
'Clears existing information ready for new update
Sheets("stats").Cells(10, 7) = ""
Sheets("stats").Cells(8, 7) = ""
Sheets("stats").Cells(12, 5) = ""
Sheets("stats").Cells(13, 5) = ""
Sheets("stats").Cells(14, 5) = ""
Sheets("stats").Cells(15, 5) = ""
Sheets("stats").Cells(9, 7) = ""
Sheets("stats").Range("b24:m28").Clear
Sheets("stats").Range("j4:j8").Clear
Sheets("stats").Range("j12:j16").Clear
Sheets("stats").Range("l4:l8").Clear
Sheets("stats").Range("b42:m42").Clear
Sheets("stats").Range("b43:m43").Clear
i = 5 'row counter for use in data sheet. Data starts at row 5
j = 0 'total number
k = 0 'Part2
l = 0 'Part3
m = 0 'Part4
n = 0 'Part5
o = 0 'Part6
p = 0 'Part7
q = 0 'Part8
R = 0 'Part9
aa = 0 'Monday
bb = 0 'Tuesday
cc = 0 'Wednesday
dd = 0 'Thursday
ee = 0 'Friday
ff = 0 'Monday
gg = 0 'Tuesday
hh = 0 'Wednesday
ii = 0 'Thursday
jj = 0 'Friday
kk = 0 'Off flows from previous cohort
ll = 0 'LED cohort month
mm = 0 'LED cohort year
temp1 = 0 'previous cohort
'Calculate available slots for each day
Do Until Sheets("data").Cells(i, 2) = ""
If Sheets("data").Cells(i, 9) = "" And Sheets("data").Cells(i, 3) = "" Then
If Sheets("data").Cells(i, 8) = "Monday" Then
aa = aa + 1
Sheets("stats").Cells(4, 10) = aa
End If
If Sheets("data").Cells(i, 8) = "Tuesday" Then
bb = bb + 1
Sheets("stats").Cells(5, 10) = bb
End If
If Sheets("data").Cells(i, 8) = "Wednesday" Then
cc = cc + 1
Sheets("stats").Cells(6, 10) = cc
End If
If Sheets("data").Cells(i, 8) = "Thursday" Then
dd = dd + 1
Sheets("stats").Cells(7, 10) = dd
End If
If Sheets("data").Cells(i, 8) = "Friday" Then
ee = ee + 1
Sheets("stats").Cells(8, 10) = ee
End If
If Sheets("data").Cells(i, 8) = "Monday" Then
ff = ff + 1
Sheets("stats").Cells(4, 12) = ff
End If
If Sheets("data").Cells(i, 8) = "Tuesday" Then
gg = gg + 1
Sheets("stats").Cells(5, 12) = gg
End If
If Sheets("data").Cells(i, 8) = "Wednesday" Then
hh = hh + 1
Sheets("stats").Cells(6, 12) = hh
End If
If Sheets("data").Cells(i, 8) = "Thursday" Then
ii = ii + 1
Sheets("stats").Cells(7, 12) = ii
End If
If Sheets("data").Cells(i, 8) = "Friday" Then
jj = jj + 1
Sheets("stats").Cells(8, 12) = jj
End If
End If
'If surname blank, continue check at next row
If Sheets("data").Cells(i, 4) = "" Then
GoTo continue_check
End If
' Add one to caseload total
j = j + 1
'If Part5 completed then remove from List total as no longer active
If Sheets("data").Cells(i, 9) <> "" Then
j = j - 1
End If
a = Month(Sheets("data").Cells(i, 27)) 'Claim cohort month
b = Year(Sheets("data").Cells(i, 27)) 'Claim cohort year
c = Month(Sheets("stats").Cells(6, 7)) 'today's cohort month
d = Year(Sheets("stats").Cells(6, 7)) 'today's cohort year
ll = Month(Sheets("data").Cells(i, 28)) 'LED cohort month
mm = Year(Sheets("data").Cells(i, 28)) 'LED cohort year
'Calculates total number of cases added in cohort
If a = c And b = d Then 'if claim month & year = current month & year [by cohort info]
' If not an off flow, then don't count and continue check at next row
If Sheets("data").Cells(i, 10) = "Section1" Or Sheets("data").Cells(i, 10) = "List2" Or Sheets("data").Cells(i, 10) = "List3" Or Sheets("data").Cells(i, 10) = "List4" Or Sheets("data").Cells(i, 10) = "List5" Or Sheets("data").Cells(i, 10) = "List6" Or Sheets("data").Cells(i, 10) = "List7" Then
GoTo continue_check
End If
Sheets("stats").Cells(8, 7) = Sheets("stats").Cells(8, 7) + 1 'Add 1 to G8 on Stats (cases received in month)
End If
'If Part3 date not blank
If Sheets("data").Cells(i, 9) <> "" Then
If Sheets("data").Cells(i, 10) = "List4" Or Sheets("data").Cells(i, 10) = "List6" _
Or Sheets("data").Cells(i, 10) = "List7" Or Sheets("data").Cells(i, 10) = "List8" _
Or Sheets("data").Cells(i, 10) = "List9" Then
a = Month(Sheets("data").Cells(i, 28)) 'LED month
b = Year(Sheets("data").Cells(i, 28)) 'LED year
temp1 = c - 1 'previous cohort
If temp1 = ll And d = mm Then 'Count off flows from previous cohort as KK
kk = kk + 1
End If
If a = c And b = d Then 'off flows within current cohort
date1 = Sheets("data").Cells(i, 7) 'List1
date2 = Sheets("data").Cells(i, 9) 'List2
' Count to overall figures & various off flow reasons
If Sheets("data").Cells(i, 10) = "List3" Then
l = l + 1
k = k + 1 'overall count for all claim ends
ElseIf Sheets("data").Cells(i, 10) = "List4" Then
m = m + 1
k = k + 1
ElseIf Sheets("data").Cells(i, 10) = "List6" Then
n = n + 1
k = k + 1
ElseIf Sheets("data").Cells(i, 10) = "List7" Then
o = o + 1
k = k + 1
ElseIf Sheets("data").Cells(i, 10) = "List8" Then
R = R + 1
k = k + 1
End If
' Original dates used rather than cohorts to calculate weeks of claim
If DateDiff("d", date1, date2) <= 91 Then 'diff between List2 & List3
Sheets("stats").Cells(12, 5) = Sheets("stats").Cells(12, 5) + 1 'add one to Option3
ElseIf DateDiff("d", date1, date2) > 91 And DateDiff("d", date1, date2) <= 182 Then
Sheets("stats").Cells(13, 5) = Sheets("stats").Cells(13, 5) + 1
ElseIf DateDiff("d", date1, date2) > 182 And DateDiff("d", date1, date2) <= 273 Then
Sheets("stats").Cells(14, 5) = Sheets("stats").Cells(14, 5) + 1
ElseIf DateDiff("d", date1, date2) > 273 And DateDiff("d", date1, date2) <= 364 Then
Sheets("stats").Cells(15, 5) = Sheets("stats").Cells(15, 5) + 1
End If
End If
End If
End If
'Calculates Cohort information by cohort month for a rolling year
For p = 2 To 13
a = Month(Sheets("data").Cells(i, 27)) 'List1
b = Year(Sheets("data").Cells(i, 27)) 'List year cohort
c = Sheets("stats").Cells(21, p) 'month on stats sheet
d = Sheets("stats").Cells(22, p) 'year on stats sheet
e = Month(Sheets("data").Cells(i, 28)) 'List4 month cohort
f = Year(Sheets("data").Cells(i, 28)) 'List year cohort
If a = c And b = d Then
' If not actually an off-flow (moves, etc.) continue check at next row
' This includes List4 as these shouldn't be counted in intake
If Sheets("data").Cells(i, 10) = "List1" Or Sheets("data").Cells(i, 10) = "List2" Or Sheets("data").Cells(i, 10) = "List3" Or Sheets("data").Cells(i, 10) = "List4" Or Sheets("data").Cells(i, 10) = "List5" Or Sheets("data").Cells(i, 10) = "List6" Or Sheets("data").Cells(i, 10) = "Transfer Out" Then
GoTo continue_check
End If
'Intake
Sheets("stats").Cells(24, p) = Sheets("stats").Cells(24, p) + 1
date1 = Sheets("data").Cells(i, 7) 'List1
date2 = Sheets("data").Cells(i, 9) 'List2
If Sheets("data").Cells(i, 9) <> "" Then
'Counting off flows from each cohort period
If Sheets("data").Cells(i, 10) = "List5" Or Sheets("data").Cells(i, 10) = "List6" _
Or Sheets("data").Cells(i, 10) = "List7" Or Sheets("data").Cells(i, 10) = "List8" _
Or Sheets("data").Cells(i, 10) = "List9" Then
If DateDiff("ww", date1, date2) <= 13 Then
Sheets("stats").Cells(25, p) = Sheets("stats").Cells(25, p) + 1
ElseIf DateDiff("ww", date1, date2) > 13 And DateDiff("ww", date1, date2) <= 26 Then
Sheets("stats").Cells(26, p) = Sheets("stats").Cells(26, p) + 1
ElseIf DateDiff("ww", date1, date2) > 26 And DateDiff("ww", date1, date2) <= 39 Then
Sheets("stats").Cells(27, p) = Sheets("stats").Cells(27, p) + 1
ElseIf DateDiff("ww", date1, date2) > 39 And DateDiff("ww", date1, date2) <= 52 Then
Sheets("stats").Cells(28, p) = Sheets("stats").Cells(28, p) + 1
End If
End If
End If
End If
Next p
For ll = 2 To 13
If Sheets("data").Cells(i, 10) = "List1" Or Sheets("data").Cells(i, 10) = "List2" Or Sheets("data").Cells(i, 10) = "List3" Or Sheets("data").Cells(i, 10) = "List4" Or Sheets("data").Cells(i, 10) = "List5" Or Sheets("data").Cells(i, 10) = "List6" Or Sheets("data").Cells(i, 10) = "List7" Then
GoTo continue_check
End If
If Sheets("data").Cells(i, 10) = "List1" Or Sheets("data").Cells(i, 10) = "List2" _
Or Sheets("data").Cells(i, 10) = "List3" Or Sheets("data").Cells(i, 10) = "List4" _
Or Sheets("data").Cells(i, 10) = "List5" Then
c = Sheets("stats").Cells(21, ll) 'cohort month looked at
d = Sheets("stats").Cells(22, ll) 'cohort year looked at
e = Month(Sheets("data").Cells(i, 27)) 'on flow cohort
f = Year(Sheets("data").Cells(i, 28)) 'off flow cohort
date1 = Sheets("data").Cells(i, 7) 'Option1
date2 = Sheets("data").Cells(i, 9) 'Option2
If d = f And c = e Then
zz = date2 - date1 'benefit duration
xx = zz / 7
Sheets("stats").Cells(42, ll) = Sheets("stats").Cells(42, ll) + xx
Sheets("stats").Cells(43, ll) = Sheets("stats").Cells(43, ll) + 1
End If
End If
Next ll
Sheets("stats").Cells(10, 7) = j 'Total caseload
Sheets("stats").Cells(9, 7) = k 'Total off flows
Sheets("stats").Cells(12, 10) = l 'Option4
Sheets("stats").Cells(13, 10) = m 'Option5
Sheets("stats").Cells(14, 10) = n 'Option6
Sheets("stats").Cells(15, 10) = o 'Option7
Sheets("stats").Cells(16, 10) = R 'Option8
Sheets("stats").Cells(9, 8) = kk 'Option9
continue_check:
i = i + 1
Loop
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
End Sub
Private Sub CommandButton7_Click() 'View Available slots - opens master spreadsheet as read only
Dim a As String
a = Sheets("lists").Cells(15, 1)
Workbooks.Open Filename:=a, UpdateLinks:=3, ReadOnly:=True, Notify:=False
Sheets("Availability").Select
End Sub
Private Sub CommandButton8_Click() 'Search for cust
'Opens master spreadsheet read only which contains PART1 and surname search buttons
Run ("macro12")
End Sub
Private Sub CommandButton9_Click() 'print screen
Dim b, d As String
Dim a As String
Dim i, j As Long
d = Sheets("lists").Cells(16, 1) 'Office name
a = Sheets("Sheet1").Cells(5, 14) 'Part4
' clears the archive sheet ready for populating
Sheets("archive").Select
Sheets("archive").Range("A1:N1000").Select
Selection.ClearContents
i = 5
j = 2
'Set up headers
Sheets("archive").Cells(1, 1) = "Option1"
Sheets("archive").Cells(1, 2) = "Option2"
Sheets("archive").Cells(1, 3) = "Option3"
Sheets("archive").Cells(1, 4) = "Option4"
Sheets("archive").Cells(1, 5) = "Option5"
Sheets("archive").Cells(1, 6) = "Option6"
Sheets("archive").Cells(1, 7) = "Option7"
Sheets("archive").Cells(1, 8) = "Option8"
Sheets("archive").Cells(1, 9) = "Option9"
Sheets("archive").Cells(1, 10) = "Option10"
Sheets("archive").Cells(1, 11) = "Option11"
Sheets("archive").Cells(1, 12) = "Option12"
Do Until Sheets("data").Cells(i, 1) = ""
'If matches signing day/cycle then put information into archive tab
If Sheets("data").Cells(i, 8) = a Then
If Sheets("data").Cells(i, 9) = "" Then 'Where live claim
Sheets("archive").Cells(j, 1) = Sheets("data").Cells(i, 8)
Sheets("archive").Cells(j, 2) = Sheets("data").Cells(i, 2)
Sheets("archive").Cells(j, 3) = Sheets("data").Cells(i, 3)
Sheets("archive").Cells(j, 4) = Sheets("data").Cells(i, 4)
Sheets("archive").Cells(j, 5) = Sheets("data").Cells(i, 5)
Sheets("archive").Cells(j, 6) = Sheets("data").Cells(i, 7)
Sheets("archive").Cells(j, 7) = Sheets("data").Cells(i, 18)
Sheets("archive").Cells(j, 8) = Sheets("data").Cells(i, 19)
Sheets("archive").Cells(j, 9) = Sheets("data").Cells(i, 20)
Sheets("archive").Cells(j, 10) = Sheets("data").Cells(i, 21)
Sheets("archive").Cells(j, 11) = Sheets("data").Cells(i, 24)
Sheets("archive").Cells(j, 12) = Sheets("data").Cells(i, 23)
j = j + 1
End If
End If
i = i + 1
Loop
'Sort archive tab in time order
Run ("SortByTime")
'Print out archive tab and clear contents. Go back to main sheet
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Sheets("archive").Range("A1:N1000").Select
Selection.ClearContents
Sheets("Sheet1").Select
End Sub
I have inherited this spreadsheet. On sheet 1 i can create times from B11 down eg 08:45 08:49 etc. The problem is i can have all the time stored on the data sheet but when i recall the times to show on sheet 1 it stops at cell B60. I have looked at the code and changed anything that had 60 to 70 but it still stops at 60. Hope this makes sense. I have attached the code below. Sorry for so much code. Thanks in advance.
Red
Private Sub clear_screen() 'Clear screen
Sheets("sheet1").Unprotect Password:="XXXXXXXX"
Sheets("data").Unprotect Password:="XXXXXXXX"
Cells(1, 18) = 0 'Cell R1
Range("L11:l70").Select
With Selection.Interior
.ColorIndex = 2
End With
' Clear all contents
Range("b11:b70").ClearContents
Range("h11:h70").ClearContents
Range("n11:n70").ClearContents
Range("d11:d70").ClearContents
Range("f11:f70").ClearContents
Range("h11:h70").ClearContents
Range("j11:j70").ClearContents
Range("l11:l70").ClearContents
Range("l11:l70").Select
Selection.Interior.ColorIndex = xlNone
Range("m11:m70").ClearContents
Range("n11:n70").ClearContents
Range("p11
70").ClearContentsRange("r11:r70").ClearContents
Range("b11:b70").ClearContents
Range("s11:s70").ClearContents
Range("m11:m70").ClearContents
Range("w11:w70").ClearContents
Range("t11:t70").ClearContents
Range("v11:v70").ClearContents
Range("w11:w70").ClearContents
Range("x11:x70").ClearContents
Range("y11:y70").ClearContents
Range("z11:z70").ClearContents
Range("aa11:aa70").ClearContents
Range("ab11:ab70").ClearContents
Range("ac11:ac70").ClearContents
Range("ad11:ad70").ClearContents
Range("t11:t70").Select
Selection.Interior.ColorIndex = xlNone
Range("D11:D70,F11:F70,H11:H70,J11:J70,B11:B70").Select
Range("B11").Activate
Selection.Locked = False
Selection.FormulaHidden = False
Cells(5, 14) = "" 'box count blank
Cells(5, 8) = "" 'day cycle blank
Range("d11:d70").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Cells(11, 4).Select
Cells(5, 14).Select
Selection.Locked = False
Sheets("sheet1").Protect Password:="XXXXXXXX"
Sheets("data").Protect Password:="XXXXXXXX"
End Sub
Private Sub CommandButton1_Click() 'Initial setup
Dim a, c, d, e, f As String
Dim b As Date
Dim i As Long
d = Sheets("lists").Cells(16, 1) 'Office name
Sheets("sheet1").Unprotect Password:="XXXXXXXX"
Sheets("data").Unprotect Password:="XXXXXXXX"
' Display message if currently has records on screen
If Cells(1, 18) = 1 Then 'Checking value cell R1 - has value 1 if records on screen
i = MsgBox("The record on screen has not been saved! Do you wish to continue?", vbYesNo, d)
If i <> 6 Then
Sheets("sheet1").Protect Password:="XXXXXXXX"
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
Else
Call clear_screen
End If
End If
a = InputBox("Please input password", d)
'Checking correct password
If a <> " XXXXXXXX " Then
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
'Need to have day/cycle selected to do initial set up
If Cells(5, 14) = "" Then
MsgBox "No Cycle/Signing Day information recorded. Please correct before proceeding!", vbInformation, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
Cells(1, 1).Select
Range("b11").ClearContents
c = InputBox("Please input the initial start time. Format should be hh:mm", d)
mycheck = c 'initial start time
If IsDate(mycheck) = False Then 'Must be valid time
MsgBox "Invalid start time entered. Please re-run set up", vbOKOnly, d
Range("d11:d70").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
c = FormatDateTime(c, vbShortTime)
'Call clear_screen
Cells(11, 2) = c 'put start time in cell B11
Range("d11:d70").Select 'Nino
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=$w$1:$w$4"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
For j = 12 To 64
If Cells(j - 1, 2) = Cells(3, 1) Then
Exit For
End If
Cells(j, 2) = Cells(j - 1, 2) + Cells(2, 1) 'set up signing times according to time in A2 till A3 end time
Next j
Cells(11, 4).Select 'Nino
MsgBox "Please input Tea/Lunch breaks etc", vbOKOnly, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
End Sub
Private Sub CommandButton10_Click() 'Print specific month
Dim b As String
Dim a, d As String
Dim i, j As Long
d = Sheets("lists").Cells(16, 1)
' clears the archive sheet ready for populating
Sheets("archive").Select
Sheets("archive").Range("A1:N1000").Select
Selection.ClearContents
'asks the user for the month they wish to print and whether it is all cases or just the outstanding.
a = InputBox("Please input the Month you wish to view in the following format 01/mm/yyyy.", d)
If IsDate(a) = False Then
MsgBox "Invalid date entered, please try again", vbExclamation, d
Exit Sub
End If
b = InputBox("Do you wish to view all cases received in month or just the outstanding?. Enter 1 for all cases and 2 for only the outstanding.", d)
If b <> "1" And b <> "2" Then
MsgBox "Invalid entry, 1 0r 2 must be entered", vbExclamation, d
Exit Sub
End If
i = 5 'Holds current row being looked at in data sheet
j = 2 'Holds row being written to in archive sheet. Starts under headings
c = Month(a) 'Month input by user
d = Year(a) 'Year input by user
'Set up headers in archive sheet
Sheets("archive").Cells(1, 1) = "Part1"
Sheets("archive").Cells(1, 2) = "Part2"
Sheets("archive").Cells(1, 3) = "Part3"
Sheets("archive").Cells(1, 4) = "Part4"
Sheets("archive").Cells(1, 5) = "Initial"
Sheets("archive").Cells(1, 6) = "Part5"
Sheets("archive").Cells(1, 7) = "Part6"
Sheets("archive").Cells(1, 8) = "Part7"
Sheets("archive").Cells(1, 9) = "Part8"
Sheets("archive").Cells(1, 10) = "Part 9"
Sheets("archive").Cells(1, 11) = "Part10"
Sheets("archive").Cells(1, 12) = "Part11"
Sheets("archive").Cells(1, 13) = "Part 12"
Sheets("archive").Cells(1, 14) = "Part 13"
'Do Until all records have been checked through
Do Until Sheets("data").Cells(i, 1) = ""
'If record matches month/year input by user
If d = Year(Sheets("data").Cells(i, 7)) And c = Month(Sheets("data").Cells(i, 7)) Then
'Continue search from next row if user has selected outstanding cases only and LED completed
If b = 2 And Sheets("data").Cells(i, 9) <> "" Then
GoTo continuesearch
End If
' Populate archive sheet
Sheets("archive").Cells(j, 1) = Sheets("data").Cells(i, 8)
Sheets("archive").Cells(j, 2) = Sheets("data").Cells(i, 2)
Sheets("archive").Cells(j, 3) = Sheets("data").Cells(i, 3)
Sheets("archive").Cells(j, 4) = Sheets("data").Cells(i, 4)
Sheets("archive").Cells(j, 5) = Sheets("data").Cells(i, 5)
Sheets("archive").Cells(j, 6) = Sheets("data").Cells(i, 7)
Sheets("archive").Cells(j, 7) = Sheets("data").Cells(i, 18)
Sheets("archive").Cells(j, 8) = Sheets("data").Cells(i, 19)
Sheets("archive").Cells(j, 9) = Sheets("data").Cells(i, 20)
Sheets("archive").Cells(j, 10) = Sheets("data").Cells(i, 21)
Sheets("archive").Cells(j, 11) = Sheets("data").Cells(i, 24)
Sheets("archive").Cells(j, 12) = Sheets("data").Cells(i, 23)
Sheets("archive").Cells(j, 13) = Sheets("data").Cells(i, 9)
Sheets("archive").Cells(j, 14) = Sheets("data").Cells(i, 10)
'Add one to count of rows
j = j + 1
End If
continuesearch:
'Add one to data sheet row to look at next row on next repetion of loop
i = i + 1
Loop
End Sub
Private Sub CommandButton11_Click() 'Remove old cases - over 13 months
Dim i As Long
Dim d As String
d = Sheets("lists").Cells(16, 1) 'd=Office name
Sheets("data").Unprotect Password:=" XXXXXXXX "
Sheets("data").Select
i = 5
Do Until Sheets("data").Cells(i, 2) = "" ' do until end of data
If Sheets("data").Cells(i, 9) <> "" Then ' If LED completed
If DateAdd("m", 13, Sheets("data").Cells(i, 9)) <= Date Then 'if older than 13 months
Sheets("data").Rows(i).Delete 'delete row from spreadsheet
i = i - 1
End If
End If
i = i + 1
Loop
Sheets("data").Unprotect Password:=" XXXXXXXX "
Sheets("Sheet1").Select
End Sub
Private Sub CommandButton12_Click() 'List search - leaves info in the archive tab
Dim b, d As String
Dim a As String
Dim i, j As Long
d = Sheets("lists").Cells(16, 1)
' clears the archive sheet ready for populating
Sheets("archive").Select
Sheets("archive").Range("A1:N1000").Select
Selection.ClearContents
a = InputBox("Please enter the List code. ")
i = 5 'counter for rows on data tab
j = 2 'counter for rows on archive tab
' Set up archive sheet headings
Sheets("archive").Cells(1, 1) = "Part1"
Sheets("archive").Cells(1, 2) = "Part2"
Sheets("archive").Cells(1, 3) = "Part3"
Sheets("archive").Cells(1, 4) = "Part4"
Sheets("archive").Cells(1, 5) = "Part5"
Sheets("archive").Cells(1, 6) = "Part6"
Sheets("archive").Cells(1, 7) = "Part7"
Sheets("archive").Cells(1, 8) = "Part 8"
Sheets("archive").Cells(1, 9) = "Part9"
Sheets("archive").Cells(1, 10) = "Part10"
Sheets("archive").Cells(1, 11) = "Part11"
Sheets("archive").Cells(1, 12) = "Part 12"
Sheets("archive").Cells(1, 13) = "Part13"
Do Until Sheets("data").Cells(i, 1) = ""
If Sheets("data").Cells(i, 9) = "" Then 'Where live
If Sheets("data").Cells(i, 19) = a Then 'search column S List code
Sheets("archive").Cells(j, 1) = Sheets("data").Cells(i, 8)
Sheets("archive").Cells(j, 2) = Sheets("data").Cells(i, 2)
Sheets("archive").Cells(j, 3) = Sheets("data").Cells(i, 3)
Sheets("archive").Cells(j, 4) = Sheets("data").Cells(i, 4)
Sheets("archive").Cells(j, 5) = Sheets("data").Cells(i, 5)
Sheets("archive").Cells(j, 6) = Sheets("data").Cells(i, 7)
Sheets("archive").Cells(j, 7) = Sheets("data").Cells(i, 18)
Sheets("archive").Cells(j, 8) = Sheets("data").Cells(i, 19)
Sheets("archive").Cells(j, 9) = Sheets("data").Cells(i, 20)
Sheets("archive").Cells(j, 10) = Sheets("data").Cells(i, 21)
Sheets("archive").Cells(j, 11) = Sheets("data").Cells(i, 24)
Sheets("archive").Cells(j, 12) = Sheets("data").Cells(i, 23)
Sheets("archive").Cells(j, 13) = Sheets("data").Cells(i, 23)
j = j + 1
End If
If Sheets("data").Cells(i, 20) = a Then 'search column T List code
Sheets("archive").Cells(j, 1) = Sheets("data").Cells(i, 8)
Sheets("archive").Cells(j, 2) = Sheets("data").Cells(i, 2)
Sheets("archive").Cells(j, 3) = Sheets("data").Cells(i, 3)
Sheets("archive").Cells(j, 4) = Sheets("data").Cells(i, 4)
Sheets("archive").Cells(j, 5) = Sheets("data").Cells(i, 5)
Sheets("archive").Cells(j, 6) = Sheets("data").Cells(i, 7)
Sheets("archive").Cells(j, 7) = Sheets("data").Cells(i, 18)
Sheets("archive").Cells(j, 8) = Sheets("data").Cells(i, 19)
Sheets("archive").Cells(j, 9) = Sheets("data").Cells(i, 20)
Sheets("archive").Cells(j, 10) = Sheets("data").Cells(i, 21)
Sheets("archive").Cells(j, 11) = Sheets("data").Cells(i, 24)
Sheets("archive").Cells(j, 12) = Sheets("data").Cells(i, 23)
j = j + 1
End If
If Sheets("data").Cells(i, 21) = a Then 'search column U List code
Sheets("archive").Cells(j, 1) = Sheets("data").Cells(i, 8)
Sheets("archive").Cells(j, 2) = Sheets("data").Cells(i, 2)
Sheets("archive").Cells(j, 3) = Sheets("data").Cells(i, 3)
Sheets("archive").Cells(j, 4) = Sheets("data").Cells(i, 4)
Sheets("archive").Cells(j, 5) = Sheets("data").Cells(i, 5)
Sheets("archive").Cells(j, 6) = Sheets("data").Cells(i, 7)
Sheets("archive").Cells(j, 7) = Sheets("data").Cells(i, 18)
Sheets("archive").Cells(j, 8) = Sheets("data").Cells(i, 19)
Sheets("archive").Cells(j, 9) = Sheets("data").Cells(i, 20)
Sheets("archive").Cells(j, 10) = Sheets("data").Cells(i, 21)
Sheets("archive").Cells(j, 11) = Sheets("data").Cells(i, 24)
Sheets("archive").Cells(j, 12) = Sheets("data").Cells(i, 23)
j = j + 1
End If
End If
i = i + 1 'Move onto next row
Loop
Sheets("archive").Select
End Sub
Private Sub CommandButton2_Click() 'Save initial setup
Dim i As Long
Dim d As String
d = Sheets("lists").Cells(16, 1) 'Office
Sheets("sheet1").Unprotect Password:=" XXXXXXXX "
Sheets("data").Unprotect Password:=" XXXXXXXX "
'Checks that information has been entered
If Cells(11, 2) = "" Then
MsgBox "No records to save!", vbExclamation, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
i = 5 'counter for data sheet row
Do Until Sheets("data").Cells(i, 2) = ""
i = i + 1
'Checks if day already set up
If Sheets("data").Cells(i, 8) = Cells(5, 14) Then
MsgBox "Records already held for this Day. Please use the recall method to view the data.", vbOKOnly, d
Call clear_screen
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
Loop
'Saves new set up
For j = 11 To 70
If Cells(j, 2) = "" Then
Exit For
Else
Sheets("data").Cells(i, 1) = Cells(j, 1)
Sheets("data").Cells(i, 2) = Cells(j, 2)
Sheets("data").Cells(i, 3) = Cells(j, 4)
Sheets("data").Cells(i, 8) = Cells(5, 14)
Sheets("data").Cells(i, 15) = Cells(3, 14)
Sheets("data").Cells(i, 17) = Cells(3, 6)
i = i + 1
End If
Next j
MsgBox "Records Saved", vbOKOnly, d
Call clear_screen
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
End Sub
Private Sub CommandButton3_Click() 'Recall records
Dim i, j, k, m As Long
Dim d As String
d = Sheets("lists").Cells(16, 1) 'name
Sheets("sheet1").Unprotect Password:=" XXXXXXXX "
Sheets("data").Unprotect Password:=" XXXXXXXX "
' Must update records on screen before can select a new day
If Cells(1, 18) = 1 Then
m = MsgBox("The records on screen have not been updated. Do you wish to continue without saving?", vbYesNo, d)
If m = 6 Then
Call clear_screen
Else
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
End If
'Must select a cycle to recall
If Cells(5, 14) = "" Then
MsgBox "No Day selected!", vbExclamation, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
i = 5 'counter for row in data sheet
k = 0
Do Until Sheets("data").Cells(i, 2) = ""
Call check_recs(i, k) 'Pull back records from data sheet
i = i + 1 'Go to next record
Loop
'Format records
Call format_recs
Cells(1, 1).Select
Cells(1, 18) = 1
Cells(5, 14).Select
Selection.Locked = True
MsgBox "Records ready for update", vbOKOnly, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
End Sub
' Uses colour format - IDOC will turn amber within 6 weeks of a key date, and red within 4
' weeks of key date. Also colours the stage they are at within their claim
Private Sub format_recs()
Dim a As Double
Dim i, j As Long
Dim d As String
d = Sheets("lists").Cells(16, 1) 'office name
For i = 11 To 70
'Works out claim stage and appropriate colour
If Cells(i, 12) <> "" Then 'if IDOC not blank
a = DateDiff("d", Cells(i, 12), Now) 'days between now and IDOC
a = a / 7 'claim week
If a <= 13 Then
Cells(i, 20) = "13 Week"
Cells(i, 20).Select
Selection.Interior.ColorIndex = 50
ElseIf a > 13 And a <= 26 Then
Cells(i, 20) = "26 Week"
Cells(i, 20).Select
Selection.Interior.ColorIndex = 6
ElseIf a > 26 And a <= 39 Then
Cells(i, 20) = "39 Week"
Cells(i, 20).Select
Selection.Interior.ColorIndex = 44
ElseIf a > 39 And a <= 52 Then
Cells(i, 20) = "52 Week"
Cells(i, 20).Select
Selection.Interior.ColorIndex = 3
ElseIf a > 52 Then
Cells(i, 20) = "Over 52"
End If
'Set amber if within 4-6 weeks of a trigger date
If a >= 7 And a < 9 Or a >= 20 And a < 22 Or a >= 33 And a < 35 Or a >= 46 And a < 48 Then
Cells(i, 12).Select
Selection.Interior.ColorIndex = 44
End If
'Set red if within 4 weeks of a trigger date
If a >= 9 And a < 13 Or a >= 22 And a < 26 Or a >= 35 And a < 39 Or a >= 48 And a < 52 Then
Cells(i, 12).Select
Selection.Interior.ColorIndex = 3
End If
End If
Next i 'move to new row
End Sub
Private Sub check_recs(i, k) 'Pull back records from data sheet
Dim j As Long
Dim d As String
d = Sheets("lists").Cells(16, 1) 'office name
' Check for box name and cycle matching information selected by user
If Sheets("data").Cells(i, 17) = Cells(3, 6) And Sheets("data").Cells(i, 8) = Cells(5, 14) Then
For j = 11 To 60
If Cells(j, 1) = Sheets("data").Cells(i, 1) And Sheets("data").Cells(i, 9) = "" Then 'if still Testing
Cells(j, 1) = Sheets("data").Cells(i, 1) 'row number (not displayed)
Cells(j, 2) = Sheets("data").Cells(i, 2) 'time
Cells(j, 4) = Sheets("data").Cells(i, 3) 'nino
If Cells(j, 4) <> "" Then 'Part entered
Cells(j, 4).Select 'Part can't be updated/overwritten to prevent errors
Selection.Locked = True
End If
Cells(j, 6) = Sheets("data").Cells(i, 4) 'surname
If Cells(j, 6) <> "" Then 'Surname can't be updated/overwritten
Cells(j, 6).Select
Selection.Locked = True
End If
Cells(j, 8) = Sheets("data").Cells(i, 5) 'initial
If Cells(j, 8) <> "" Then 'Initial can't be updated/overwritten
Cells(j, 8).Select
Selection.Locked = True
End If
'All of the below can be updated by adviser/assistant adviser if necessary
Cells(j, 10) = Sheets("data").Cells(i, 6) 'Part1
Cells(j, 12) = Sheets("data").Cells(i, 7) 'Part2
Cells(j, 13) = Sheets("data").Cells(i, 18) 'Part3
Cells(j, 14) = Sheets("data").Cells(i, 9) 'Part4
Cells(j, 16) = Sheets("data").Cells(i, 10) 'Part5
Cells(j, 18) = Sheets("data").Cells(i, 16) 'Part6.
Cells(j, 22) = Sheets("data").Cells(i, 19) 'Part7
Cells(j, 23) = Sheets("data").Cells(i, 20) 'Part8
Cells(j, 24) = Sheets("data").Cells(i, 21) 'Part9
Cells(j, 26) = Sheets("data").Cells(i, 22) 'Part10
Cells(j, 27) = Sheets("data").Cells(i, 23) 'Part11
Cells(j, 28) = Sheets("data").Cells(i, 24) 'Part 12
Cells(j, 29) = Sheets("data").Cells(i, 25) 'Part13
Cells(j, 30) = Sheets("data").Cells(i, 26) 'Part14
If Sheets("data").Cells(i, 4) <> "" And Sheets("data").Cells(i, 9) = "" Then
Cells(5, 8) = Cells(5, 8) + 1 'update box count for live records
End If
Cells(j, 19) = i 'row number held in column s for use when records updated later
End If
Next j
End If
End Sub
Private Sub check_reason(a) 'Checks that both Part5& Part6 are recorded if one is
Dim j As Long
Dim b, c, f As String
Dim d, e As Date
f = Sheets("lists").Cells(16, 1) 'Office name
a = 0
'Search through all records on screen
For j = 11 To 70
'If time blank, reached end of signing slots so exit subroutine
If Cells(j, 2) = "" Then
Exit Sub
End If
'Checks if LED completed without a reason. User cannot proceed with update until corrected
If Cells(j, 14) <> "" And Cells(j, 16) = "" Then
c = Cells(j, 8) + " " + Cells(j, 6)
b = "Last effective date recorded for " + c + " but no reason recorded. please correct before proceeding!"
MsgBox b, vbOKOnly, f
a = 1
Exit Sub
End If
'Checks if off flow reason has been recorded without a date. User cannot proceed with update until corrected.
If Cells(j, 16) <> "" And Cells(j, 14) = "" Then
c = Cells(j, 8) + " " + Cells(j, 6)
b = "Off flow reason recorded for " + c + " but no date recorded. please correct before proceeding!"
MsgBox b, vbOKOnly, f
a = 1
Exit Sub
End If
Next j
End Sub
Private Sub check_date(b) 'Checks dates entered are valid
Dim i As Integer
Dim c, d As String
d = Sheets("lists").Cells(16, 1) 'office name
'Searches through all data on sheet
For i = 11 To 70
'If LED has been input, checks it is a valid date. User must correct before records can be updated
If Cells(i, 14) <> "" Then
mycheck = IsDate(Cells(i, 14))
If mycheck = False Then
b = 1
c = "Incorrect last effective date input for " + Cells(i, 8) + " " + Cells(i, 6) + ". Please correct before proceeding"
MsgBox c
Exit Sub
End If
End If
'If Part1 has been input, checks it is a valid date. User must correct before records can be updated
If Cells(i, 10) <> "" Then
mycheck = IsDate(Cells(i, 10))
If mycheck = False Then
b = 1
c = "Incorrect date of birth input for " + Cells(i, 8) + " " + Cells(i, 6) + ". Please correct before proceeding"
MsgBox c
Exit Sub
End If
End If
'If Part7 has been input, checks it is a valid date. User must correct before records can be updated
If Cells(i, 12) <> "" Then
mycheck = IsDate(Cells(i, 12))
If mycheck = False Then
b = 1
c = "Incorrect date of IDOC input for " + Cells(i, 8) + " " + Cells(i, 6) + ". Please correct before proceeding"
MsgBox c
Exit Sub
End If
End If
Next i
End Sub
Private Sub CommandButton4_Click() 'Update records
Dim i, j, k, l As Long
Dim a, b As Integer
Dim d As String
Dim date1, date2 As Date
d = Sheets("lists").Cells(16, 1) 'd = 'Office Name
Sheets("sheet1").Unprotect Password:=" XXXXXXXX "
Sheets("data").Unprotect Password:=" XXXXXXXX "
'Checks that records are displayed on screen to update
If Cells(11, 2) = "" Then
MsgBox "No records to update!", vbExclamation, d
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
b = 0
Call check_date(b) 'checking valid LED dates entered
If b = 1 Then
Exit Sub
End If
Call check_reason(a) 'Check if Part3, reason recorded & vice versa
If a = 1 Then
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
End If
'Displays warning message if sheet opened in read only
If ActiveWorkbook.ReadOnly Then
MsgBox "You do not have full access to the spreadsheet at this time. Changes will NOT be saved.", vbExclamation, d
Exit Sub
End If
i = 5
Do Until Sheets("data").Cells(i, 2) = "" 'count of number of slots
i = i + 1
Loop
'Check all data on sheet
For j = 11 To 70
If Cells(j, 2) = "" Then
Exit For
Else
'Updates each row on the data sheet with information held/input on main sheet.
If Cells(j, 19) <> "" Then 'when col S not blank (original row number held here)
k = Cells(j, 19) ' row on data sheet that record relates to
Sheets("data").Cells(k, 1) = Cells(j, 1) ' Part1
Sheets("data").Cells(k, 2) = Cells(j, 2) ' Part2
Sheets("data").Cells(k, 3) = UCase(Cells(j, 4)) ' Part3
Sheets("data").Cells(k, 4) = UCase(Cells(j, 6)) ' Part4
Sheets("data").Cells(k, 5) = UCase(Cells(j, 8)) ' Part5
Sheets("data").Cells(k, 6) = Cells(j, 10) ' Part6
Sheets("data").Cells(k, 7) = Cells(j, 12) ' Part7
Sheets("data").Cells(k, 8) = Cells(5, 14) ' Part8
Sheets("data").Cells(k, 18) = Cells(j, 13) ' Part9
Sheets("data").Cells(k, 19) = Cells(j, 22) ' Part10
Sheets("data").Cells(k, 20) = Cells(j, 23) ' Part11
Sheets("data").Cells(k, 21) = Cells(j, 24) ' Part 12
Sheets("data").Cells(k, 22) = Cells(j, 26) ' Part 13
Sheets("data").Cells(k, 23) = Cells(j, 27) ' Part 14
Sheets("data").Cells(k, 24) = Cells(j, 28) ' Part 15
Sheets("data").Cells(k, 25) = Cells(j, 29) ' Part 16
Sheets("data").Cells(k, 26) = Cells(j, 30) ' Part 17
Sheets("data").Cells(k, 9) = Cells(j, 14) 'Part 18
'Works out which on flow cohort the claimant belongs to
If Sheets("data").Cells(k, 27) = "" Then 'If Cohort not completed
CohortCount = 1 'counts rows on cohorts so that checks until end. New cohorts can be added
Do Until Sheets("Cohorts").Cells(CohortCount, 1) = "" 'Do Until checked all cohorts
If Sheets("data").Cells(k, 7) >= (Sheets("Cohorts").Cells(CohortCount, 1)) And Sheets("data").Cells(k, 7) <= Sheets("Cohorts").Cells(CohortCount, 2) Then
Cohort = Sheets("Cohorts").Cells(CohortCount, 3)
Sheets("data").Cells(k, 27) = Cohort
End If
CohortCount = CohortCount + 1
Loop
End If
'if LED is completed create new record on data sheet for populating & update off flow cohort
If Cells(j, 14) <> "" Then
Sheets("data").Cells(i, 1) = Cells(j, 1) ' Part1
Sheets("data").Cells(i, 2) = Cells(j, 2) ' Part2
Sheets("data").Cells(i, 8) = Cells(5, 14) ' Part3
Sheets("data").Cells(i, 15) = Cells(3, 14) ' Part4
Sheets("data").Cells(i, 17) = Cells(3, 6) ' Part5
i = i + 1
'Update data sheet to show which stage claimant off flowed at
If Cells(j, 16) = "Part1" Or Cells(j, 16) = "Part2" Or Cells(j, 16) = "Part3" _
Or Cells(j, 16) = "Part4" Or Cells(j, 16) = "Part5" Then
date1 = Sheets("data").Cells(k, 7) 'Part6
date2 = Sheets("data").Cells(k, 9) 'Part7
If DateDiff("d", date1, date2) <= 91 Then 'Part9
Sheets("data").Cells(k, 11) = 1
ElseIf DateDiff("d", date1, date2) > 91 And DateDiff("d", date1, date2) <= 182 Then 'Part11
Sheets("data").Cells(k, 12) = 1
ElseIf DateDiff("d", date1, date2) > 182 And DateDiff("d", date1, date2) <= 273 Then 'Part14
Sheets("data").Cells(k, 13) = 1
ElseIf DateDiff("d", date1, date2) > 273 And DateDiff("d", date1, date2) <= 364 Then 'Part16
Sheets("data").Cells(k, 14) = 1
End If
End If
End If
'Calculate off flow cohort
If Cells(j, 14) <> "" And Sheets("data").Cells(k, 28) = "" Then 'If LED entered and cohort not completed
OffCount = 1 'counts rows on cohorts so that checks until end. New cohorts can be added
Do Until Sheets("Cohorts").Cells(OffCount, 1) = "" 'Do Until checked all cohorts
If Sheets("data").Cells(k, 9) >= (Sheets("Cohorts").Cells(OffCount, 1)) And Sheets("data").Cells(k, 7) <= Sheets("Cohorts").Cells(OffCount, 2) Then
OffCohort = Sheets("Cohorts").Cells(OffCount, 3)
Sheets("data").Cells(k, 28) = OffCohort
End If
OffCount = OffCount + 1
Loop
End If
'Update remainder of information in data tab
Sheets("data").Cells(k, 10) = Cells(j, 16) ' Part1
Sheets("data").Cells(k, 15) = Cells(3, 14) ' Part2
Sheets("data").Cells(k, 16) = Cells(j, 18) ' Part3
Sheets("data").Cells(k, 17) = Cells(3, 6) ' Part4
End If
End If
Next j
'Advise user that records have been updated and save spreadsheet
MsgBox "Records Updated", vbOKOnly, d
Call clear_screen
ActiveWorkbook.Save
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
End Sub
Private Sub CommandButton5_Click() 'Exit (runs stats on exit)
Dim a As Integer
Dim d As String
d = Sheets("lists").Cells(16, 1) 'Office name
' Checks if records have been saved before allowing user to exit
If Cells(1, 18) = 1 Then
a = MsgBox("The record on screen has not been saved do you wish to save and exit now?", vbYesNo, d)
If a = 6 Then 'If yes to save
Call CommandButton4_Click
Call run_stats
ActiveWorkbook.Close SaveChanges:=True
End If
Else
Call run_stats
ActiveWorkbook.Close SaveChanges:=True
End If
End Sub
Private Sub CommandButton6_Click() 'Clear screen functionality - not currently used
Dim i As Integer
Dim d As String
d = Sheets("lists").Cells(16, 1)
'Checks if user wishes to continue as clear screen does not save any updates
If Cells(1, 18) = 1 Then
i = MsgBox("The record on screen has not been saved! Do you wish to continue?", vbYesNo, d)
If i <> 6 Then
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
Exit Sub
Else
Call clear_screen
End If
End If
Call clear_screen
End Sub
Private Sub run_stats() 'Called when exit button is used to update stats worksheet
Dim i, j As Long
Dim date1, date2 As Date
Dim a, b, c, d, e, f, p, q, aa, bb, cc, dd, ee, ff, gg, hh, ii, jj, kk, ll, mm, temp1, zz As Long
Dim check1 As String
Dim xx As Double
' Displays error message if user has no data in spreadsheet
If Sheets("data").Cells(5, 2) = "" Then
MsgBox "No data recorded", vbOKOnly, "Office Name"
Exit Sub
End If
Sheets("sheet1").Unprotect Password:=" XXXXXXXX "
Sheets("data").Unprotect Password:=" XXXXXXXX "
Sheets("stats").Unprotect Password:=" XXXXXXXX "
'Clears existing information ready for new update
Sheets("stats").Cells(10, 7) = ""
Sheets("stats").Cells(8, 7) = ""
Sheets("stats").Cells(12, 5) = ""
Sheets("stats").Cells(13, 5) = ""
Sheets("stats").Cells(14, 5) = ""
Sheets("stats").Cells(15, 5) = ""
Sheets("stats").Cells(9, 7) = ""
Sheets("stats").Range("b24:m28").Clear
Sheets("stats").Range("j4:j8").Clear
Sheets("stats").Range("j12:j16").Clear
Sheets("stats").Range("l4:l8").Clear
Sheets("stats").Range("b42:m42").Clear
Sheets("stats").Range("b43:m43").Clear
i = 5 'row counter for use in data sheet. Data starts at row 5
j = 0 'total number
k = 0 'Part2
l = 0 'Part3
m = 0 'Part4
n = 0 'Part5
o = 0 'Part6
p = 0 'Part7
q = 0 'Part8
R = 0 'Part9
aa = 0 'Monday
bb = 0 'Tuesday
cc = 0 'Wednesday
dd = 0 'Thursday
ee = 0 'Friday
ff = 0 'Monday
gg = 0 'Tuesday
hh = 0 'Wednesday
ii = 0 'Thursday
jj = 0 'Friday
kk = 0 'Off flows from previous cohort
ll = 0 'LED cohort month
mm = 0 'LED cohort year
temp1 = 0 'previous cohort
'Calculate available slots for each day
Do Until Sheets("data").Cells(i, 2) = ""
If Sheets("data").Cells(i, 9) = "" And Sheets("data").Cells(i, 3) = "" Then
If Sheets("data").Cells(i, 8) = "Monday" Then
aa = aa + 1
Sheets("stats").Cells(4, 10) = aa
End If
If Sheets("data").Cells(i, 8) = "Tuesday" Then
bb = bb + 1
Sheets("stats").Cells(5, 10) = bb
End If
If Sheets("data").Cells(i, 8) = "Wednesday" Then
cc = cc + 1
Sheets("stats").Cells(6, 10) = cc
End If
If Sheets("data").Cells(i, 8) = "Thursday" Then
dd = dd + 1
Sheets("stats").Cells(7, 10) = dd
End If
If Sheets("data").Cells(i, 8) = "Friday" Then
ee = ee + 1
Sheets("stats").Cells(8, 10) = ee
End If
If Sheets("data").Cells(i, 8) = "Monday" Then
ff = ff + 1
Sheets("stats").Cells(4, 12) = ff
End If
If Sheets("data").Cells(i, 8) = "Tuesday" Then
gg = gg + 1
Sheets("stats").Cells(5, 12) = gg
End If
If Sheets("data").Cells(i, 8) = "Wednesday" Then
hh = hh + 1
Sheets("stats").Cells(6, 12) = hh
End If
If Sheets("data").Cells(i, 8) = "Thursday" Then
ii = ii + 1
Sheets("stats").Cells(7, 12) = ii
End If
If Sheets("data").Cells(i, 8) = "Friday" Then
jj = jj + 1
Sheets("stats").Cells(8, 12) = jj
End If
End If
'If surname blank, continue check at next row
If Sheets("data").Cells(i, 4) = "" Then
GoTo continue_check
End If
' Add one to caseload total
j = j + 1
'If Part5 completed then remove from List total as no longer active
If Sheets("data").Cells(i, 9) <> "" Then
j = j - 1
End If
a = Month(Sheets("data").Cells(i, 27)) 'Claim cohort month
b = Year(Sheets("data").Cells(i, 27)) 'Claim cohort year
c = Month(Sheets("stats").Cells(6, 7)) 'today's cohort month
d = Year(Sheets("stats").Cells(6, 7)) 'today's cohort year
ll = Month(Sheets("data").Cells(i, 28)) 'LED cohort month
mm = Year(Sheets("data").Cells(i, 28)) 'LED cohort year
'Calculates total number of cases added in cohort
If a = c And b = d Then 'if claim month & year = current month & year [by cohort info]
' If not an off flow, then don't count and continue check at next row
If Sheets("data").Cells(i, 10) = "Section1" Or Sheets("data").Cells(i, 10) = "List2" Or Sheets("data").Cells(i, 10) = "List3" Or Sheets("data").Cells(i, 10) = "List4" Or Sheets("data").Cells(i, 10) = "List5" Or Sheets("data").Cells(i, 10) = "List6" Or Sheets("data").Cells(i, 10) = "List7" Then
GoTo continue_check
End If
Sheets("stats").Cells(8, 7) = Sheets("stats").Cells(8, 7) + 1 'Add 1 to G8 on Stats (cases received in month)
End If
'If Part3 date not blank
If Sheets("data").Cells(i, 9) <> "" Then
If Sheets("data").Cells(i, 10) = "List4" Or Sheets("data").Cells(i, 10) = "List6" _
Or Sheets("data").Cells(i, 10) = "List7" Or Sheets("data").Cells(i, 10) = "List8" _
Or Sheets("data").Cells(i, 10) = "List9" Then
a = Month(Sheets("data").Cells(i, 28)) 'LED month
b = Year(Sheets("data").Cells(i, 28)) 'LED year
temp1 = c - 1 'previous cohort
If temp1 = ll And d = mm Then 'Count off flows from previous cohort as KK
kk = kk + 1
End If
If a = c And b = d Then 'off flows within current cohort
date1 = Sheets("data").Cells(i, 7) 'List1
date2 = Sheets("data").Cells(i, 9) 'List2
' Count to overall figures & various off flow reasons
If Sheets("data").Cells(i, 10) = "List3" Then
l = l + 1
k = k + 1 'overall count for all claim ends
ElseIf Sheets("data").Cells(i, 10) = "List4" Then
m = m + 1
k = k + 1
ElseIf Sheets("data").Cells(i, 10) = "List6" Then
n = n + 1
k = k + 1
ElseIf Sheets("data").Cells(i, 10) = "List7" Then
o = o + 1
k = k + 1
ElseIf Sheets("data").Cells(i, 10) = "List8" Then
R = R + 1
k = k + 1
End If
' Original dates used rather than cohorts to calculate weeks of claim
If DateDiff("d", date1, date2) <= 91 Then 'diff between List2 & List3
Sheets("stats").Cells(12, 5) = Sheets("stats").Cells(12, 5) + 1 'add one to Option3
ElseIf DateDiff("d", date1, date2) > 91 And DateDiff("d", date1, date2) <= 182 Then
Sheets("stats").Cells(13, 5) = Sheets("stats").Cells(13, 5) + 1
ElseIf DateDiff("d", date1, date2) > 182 And DateDiff("d", date1, date2) <= 273 Then
Sheets("stats").Cells(14, 5) = Sheets("stats").Cells(14, 5) + 1
ElseIf DateDiff("d", date1, date2) > 273 And DateDiff("d", date1, date2) <= 364 Then
Sheets("stats").Cells(15, 5) = Sheets("stats").Cells(15, 5) + 1
End If
End If
End If
End If
'Calculates Cohort information by cohort month for a rolling year
For p = 2 To 13
a = Month(Sheets("data").Cells(i, 27)) 'List1
b = Year(Sheets("data").Cells(i, 27)) 'List year cohort
c = Sheets("stats").Cells(21, p) 'month on stats sheet
d = Sheets("stats").Cells(22, p) 'year on stats sheet
e = Month(Sheets("data").Cells(i, 28)) 'List4 month cohort
f = Year(Sheets("data").Cells(i, 28)) 'List year cohort
If a = c And b = d Then
' If not actually an off-flow (moves, etc.) continue check at next row
' This includes List4 as these shouldn't be counted in intake
If Sheets("data").Cells(i, 10) = "List1" Or Sheets("data").Cells(i, 10) = "List2" Or Sheets("data").Cells(i, 10) = "List3" Or Sheets("data").Cells(i, 10) = "List4" Or Sheets("data").Cells(i, 10) = "List5" Or Sheets("data").Cells(i, 10) = "List6" Or Sheets("data").Cells(i, 10) = "Transfer Out" Then
GoTo continue_check
End If
'Intake
Sheets("stats").Cells(24, p) = Sheets("stats").Cells(24, p) + 1
date1 = Sheets("data").Cells(i, 7) 'List1
date2 = Sheets("data").Cells(i, 9) 'List2
If Sheets("data").Cells(i, 9) <> "" Then
'Counting off flows from each cohort period
If Sheets("data").Cells(i, 10) = "List5" Or Sheets("data").Cells(i, 10) = "List6" _
Or Sheets("data").Cells(i, 10) = "List7" Or Sheets("data").Cells(i, 10) = "List8" _
Or Sheets("data").Cells(i, 10) = "List9" Then
If DateDiff("ww", date1, date2) <= 13 Then
Sheets("stats").Cells(25, p) = Sheets("stats").Cells(25, p) + 1
ElseIf DateDiff("ww", date1, date2) > 13 And DateDiff("ww", date1, date2) <= 26 Then
Sheets("stats").Cells(26, p) = Sheets("stats").Cells(26, p) + 1
ElseIf DateDiff("ww", date1, date2) > 26 And DateDiff("ww", date1, date2) <= 39 Then
Sheets("stats").Cells(27, p) = Sheets("stats").Cells(27, p) + 1
ElseIf DateDiff("ww", date1, date2) > 39 And DateDiff("ww", date1, date2) <= 52 Then
Sheets("stats").Cells(28, p) = Sheets("stats").Cells(28, p) + 1
End If
End If
End If
End If
Next p
For ll = 2 To 13
If Sheets("data").Cells(i, 10) = "List1" Or Sheets("data").Cells(i, 10) = "List2" Or Sheets("data").Cells(i, 10) = "List3" Or Sheets("data").Cells(i, 10) = "List4" Or Sheets("data").Cells(i, 10) = "List5" Or Sheets("data").Cells(i, 10) = "List6" Or Sheets("data").Cells(i, 10) = "List7" Then
GoTo continue_check
End If
If Sheets("data").Cells(i, 10) = "List1" Or Sheets("data").Cells(i, 10) = "List2" _
Or Sheets("data").Cells(i, 10) = "List3" Or Sheets("data").Cells(i, 10) = "List4" _
Or Sheets("data").Cells(i, 10) = "List5" Then
c = Sheets("stats").Cells(21, ll) 'cohort month looked at
d = Sheets("stats").Cells(22, ll) 'cohort year looked at
e = Month(Sheets("data").Cells(i, 27)) 'on flow cohort
f = Year(Sheets("data").Cells(i, 28)) 'off flow cohort
date1 = Sheets("data").Cells(i, 7) 'Option1
date2 = Sheets("data").Cells(i, 9) 'Option2
If d = f And c = e Then
zz = date2 - date1 'benefit duration
xx = zz / 7
Sheets("stats").Cells(42, ll) = Sheets("stats").Cells(42, ll) + xx
Sheets("stats").Cells(43, ll) = Sheets("stats").Cells(43, ll) + 1
End If
End If
Next ll
Sheets("stats").Cells(10, 7) = j 'Total caseload
Sheets("stats").Cells(9, 7) = k 'Total off flows
Sheets("stats").Cells(12, 10) = l 'Option4
Sheets("stats").Cells(13, 10) = m 'Option5
Sheets("stats").Cells(14, 10) = n 'Option6
Sheets("stats").Cells(15, 10) = o 'Option7
Sheets("stats").Cells(16, 10) = R 'Option8
Sheets("stats").Cells(9, 8) = kk 'Option9
continue_check:
i = i + 1
Loop
Sheets("sheet1").Protect Password:=" XXXXXXXX "
Sheets("data").Protect Password:=" XXXXXXXX "
Sheets("stats").Protect Password:=" XXXXXXXX "
End Sub
Private Sub CommandButton7_Click() 'View Available slots - opens master spreadsheet as read only
Dim a As String
a = Sheets("lists").Cells(15, 1)
Workbooks.Open Filename:=a, UpdateLinks:=3, ReadOnly:=True, Notify:=False
Sheets("Availability").Select
End Sub
Private Sub CommandButton8_Click() 'Search for cust
'Opens master spreadsheet read only which contains PART1 and surname search buttons
Run ("macro12")
End Sub
Private Sub CommandButton9_Click() 'print screen
Dim b, d As String
Dim a As String
Dim i, j As Long
d = Sheets("lists").Cells(16, 1) 'Office name
a = Sheets("Sheet1").Cells(5, 14) 'Part4
' clears the archive sheet ready for populating
Sheets("archive").Select
Sheets("archive").Range("A1:N1000").Select
Selection.ClearContents
i = 5
j = 2
'Set up headers
Sheets("archive").Cells(1, 1) = "Option1"
Sheets("archive").Cells(1, 2) = "Option2"
Sheets("archive").Cells(1, 3) = "Option3"
Sheets("archive").Cells(1, 4) = "Option4"
Sheets("archive").Cells(1, 5) = "Option5"
Sheets("archive").Cells(1, 6) = "Option6"
Sheets("archive").Cells(1, 7) = "Option7"
Sheets("archive").Cells(1, 8) = "Option8"
Sheets("archive").Cells(1, 9) = "Option9"
Sheets("archive").Cells(1, 10) = "Option10"
Sheets("archive").Cells(1, 11) = "Option11"
Sheets("archive").Cells(1, 12) = "Option12"
Do Until Sheets("data").Cells(i, 1) = ""
'If matches signing day/cycle then put information into archive tab
If Sheets("data").Cells(i, 8) = a Then
If Sheets("data").Cells(i, 9) = "" Then 'Where live claim
Sheets("archive").Cells(j, 1) = Sheets("data").Cells(i, 8)
Sheets("archive").Cells(j, 2) = Sheets("data").Cells(i, 2)
Sheets("archive").Cells(j, 3) = Sheets("data").Cells(i, 3)
Sheets("archive").Cells(j, 4) = Sheets("data").Cells(i, 4)
Sheets("archive").Cells(j, 5) = Sheets("data").Cells(i, 5)
Sheets("archive").Cells(j, 6) = Sheets("data").Cells(i, 7)
Sheets("archive").Cells(j, 7) = Sheets("data").Cells(i, 18)
Sheets("archive").Cells(j, 8) = Sheets("data").Cells(i, 19)
Sheets("archive").Cells(j, 9) = Sheets("data").Cells(i, 20)
Sheets("archive").Cells(j, 10) = Sheets("data").Cells(i, 21)
Sheets("archive").Cells(j, 11) = Sheets("data").Cells(i, 24)
Sheets("archive").Cells(j, 12) = Sheets("data").Cells(i, 23)
j = j + 1
End If
End If
i = i + 1
Loop
'Sort archive tab in time order
Run ("SortByTime")
'Print out archive tab and clear contents. Go back to main sheet
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Sheets("archive").Range("A1:N1000").Select
Selection.ClearContents
Sheets("Sheet1").Select
End Sub
