Hi all, i have created a problem for myself, i have 3 named range
hols1,2 and 3 which covers everyones holidays, in order for anothe
date to be entered the user enters a new date in spare cells below th
ranges and the persons name, when the program is closed it sorts al
the cells over a numbered range in date order.......my problem i
this...............when it sorts and you re open the program the range
havent expanded when the new rows have been sorted in to place and it
throwing all my figures out below is my code....all of it but it woul
be better if you could see the workbook and what im trying t
achieve...can you help?

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 t
= "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 Hour
" & 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


--
Simon Lloyd
------------------------------------------------------------------------
Simon Lloyd's Profile: http://www.excelforum.com/member.php...fo&userid=6708
View this thread: http://www.excelforum.com/showthread...hreadid=489095

use a defined name for the range or something like

x=cells(rows.count,"a").end(xlup).row
Range("A14:AK" & x).sort Key1:=Range("A14"), Order1:=xlAscending
===========
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

above could be (NO selection)

with Worksheets("gbk track")
..range("a2").insert
..range("a2")=now
end with

--
Don Guillett
SalesAid Software

"Simon Lloyd"
wrote in message
...

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?

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


--
Simon Lloyd
------------------------------------------------------------------------
Simon Lloyd's Profile:
http://www.excelforum.com/member.php...fo&userid=6708
View this thread: http://www.excelforum.com/showthread...hreadid=489095

Thanks for your reply Don, but i may not have explained myself well
enough!. The portion of code you highlighted where i have the gb track
is just to track who logged on, the named ranges are on the same sheet
in blocks one after the other like this Hols1 $D$14:$AK$121, Hols2
$D$122:$AK$334, Hols3 $D$335:$AK$416 and the rows that people can add
to these ranges are at the bottom i.e below row 416, they just add a
date and and name and when the program closes it sorts in date order
but when it does this it is not expanding the named range just moving
it by however many entries.

can you help any further?

Simon


--
Simon Lloyd
------------------------------------------------------------------------
Simon Lloyd's Profile: http://www.excelforum.com/member.php...fo&userid=6708
View this thread: http://www.excelforum.com/showthread...hreadid=489095