LinkBack URL
About LinkBacks
Hi all, i have created a problem for myself, i have 3 named ranges hols1,2 and 3 which covers everyones holidays, in order for another date to be entered the user enters a new date in spare cells below the ranges and the persons name, when the program is closed it sorts all the cells over a numbered range in date order.......my problem is this...............when it sorts and you re open the program the ranges havent expanded when the new rows have been sorted in to place and its throwing all my figures out below is my code....all of it but it would be better if you could see the workbook and what im trying to achieve...can you help?
The named ranges cover these cells:- Hols1 $D$14:$AK$121, Hols2 $D$122:$AK$334, Hols3 $D$335:$AK$416
Simon
Sub auto_close()
Sheets("Holidays").Select
ActiveSheet.Unprotect
EnableEvents = False
With Application
.EnableEvents = False
.Calculation = xlManual
.MaxChange = 0.001
.CalculateBeforeSave = False
End With
ActiveWorkbook.PrecisionAsDisplayed = False
Range("A14:AK545").Select
Selection.sort Key1:=Range("A14"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("a1").Select
Application.DisplayAlerts = False
Application.DisplayFormulaBar = True
ActiveCell = xlNone
With Application
.Calculation = xlAutomatic
End With
ActiveSheet.Protect
ActiveWorkbook.Save
End Sub
Sub Auto_open()
Dim t1 As String
Dim I1 As Integer
Dim I2 As Integer
Application.DisplayAlerts = False
Application.DisplayFormulaBar = False
Sheets("logged").Visible = False
Range("A1").Select
ActiveCell = xlNone
With Application
.EnableEvents = True
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
For I2 = 1 To 3
t1 = InputBox("Enter Your GBK Login", "Login Verification", "")
If t1 = "gbksxl04" Or t1 = "gbkdxb02" Or t1 = "gbkmxg04" Or t1 = "gbkaxp02" Or t1 = "gbkbxs03" Or t1 = "gbkhxb03" Or t1 = "gbksxh03" Or t1 = "gbktah01" Then
ActiveCell = t1
Call startup
Exit Sub
Else
Worksheets("gbk track").Visible = True
Worksheets("gbk track").Select
ActiveSheet.Range("a2").Select
Selection.EntireRow.Insert Shift:=xlDown
Selection = t1 & " " & Now
Worksheets("gbk track").Visible = False
End If
Next 'I2
'MsgBox "Buzz Off " & t1
MsgBox "Please Contact Your Shift Manager " & Chr(13) & "The Entry " & t1 & " not recognised"
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
Sub dateselect()
Dim mycell
Dim todaydate As Range
Dim rng As Range
Dim offset
Set rng = Range("todaydate")
For Each mycell In rng
If mycell.Value = Date Then
mycell.Select
MsgBox "Today is " & ActiveCell.Value
Exit Sub
End If
Next 'mycell
End Sub
Sub startup()
Dim ccount As Integer
Dim cccount
Worksheets("Holidays").Select
Range("B5").Select
ActiveCell.FormulaR1C1 = "=COUNTBYCOLOR(R[9]C[-1]:R[540]C[-1],38,FALSE)" '484
ccount = Range("b5")
Range("B6").Select
ActiveCell.FormulaR1C1 = "=countbyindex(R[8]C[2]:R[540]C[35])" '505
cccount = Range("B6").Value
Worksheets("holidays").Visible = True
Worksheets("Holiday Count").Visible = True
Worksheets("Xtra's & Count").Visible = True
Sheets("holidays").Activate
MsgBox "There Are " & ccount & " Holiday Clashes" & Chr(13) & " There Have Been " & cccount & " accomodations" & Chr(13) & "Total Hours " & Range("b10").Value & ", Hours Taken " & Range("b12").Value & ", Hours Left to take " & Range("b11").Value, vbOKOnly, "Clash Count"
Call findvalue
Call dateselect
Worksheets("Names").Visible = False
With ThisWorkbook.Worksheets("Names").Cells(Rows.Count, "A").End(xlUp)
.offset(1, 0).Value = Range("A1").Text
.offset(1, 1).Value = Format(Now, "dd mmm yyyy, hh:mm")
.offset(1, 2).Value = Application.UserName
End With
Call logtrack
End Sub
Function countbycolor(InRange As Range, WhatColorIndex As Integer, Optional OfText As Boolean = False) As Long
Dim rng As Range
Application.Volatile True
For Each rng In InRange.Cells
If IsDate(rng) Then
If IsNumeric(rng) Then
countbycolor = countbycolor - _
(rng.Font.ColorIndex = WhatColorIndex)
Else
countbycolor = countbycolor - _
(rng.Interior.ColorIndex = WhatColorIndex)
End If
End If
Next rng
End Function
Function countbyindex(ByVal cbc As Range) As Integer
rng_col_count = cbc.Columns.Count
rng_row_count = cbc.Rows.Count
For times = 2 To rng_col_count Step 2
Set tmp_cbc = cbc.Range(Cells(1, times), Cells(rng_row_count, times))
For Each i In tmp_cbc
If i.Interior.ColorIndex = 38 Then
If i >= 1 And i <= 12 Then
f = f + 1
End If
End If
Next i
Next times
countbyindex = f
End Function
Sub logtrack()
Sheets("logged").Visible = True
With ThisWorkbook.Worksheets("logged").Cells(Rows.Count, "A").End(xlUp)
Sheets("logged").Visible = False
End With
End Sub
Sub findvalue()
Dim mycell
Dim findme As Range
Dim rng As Range
Dim offset
On Error Resume Next
Set rng = Range("findme1")
For Each mycell In rng
If mycell.Text >= 129 Then
MsgBox (mycell.offset(0, -1).Text) & " Has Booked " & (mycell.Text - 128) & " Hours Off Over Their Quota of 128!", vbOKOnly, "More Than Their Quota!"
End If
Next mycell
End Sub
Register To Reply
Bookmarks