Performance issue and error in Excel vba - vba

Question

I have created a code for getting unique value from a column which is filled with date and from that unique column i have compare whether it is Sunday or Monday or Tuesday or etc and if it falls in between two time stamp [2:00:00 am to 2:59:59 am] i increment but if on same date for example 1/5/2014 it falls in two time stamp again[2:00:00 am - 2:59:59 am] i should not increment and if in the same date it falls in another time stamp it should increment that too only once.
It is working for 50 -100 rows but for 200k of rows it is hanging.
Private Sub CommandButton1_Click()
Range("I2:O25") = ""
Set Range1 = Range("B:B")
Dim dates As Variant
Dim Array1() As Variant
Dim MyArray1(24, 7) As Integer
Array1 = UniqueItems(Range1, False)
For Each dates In Array1
If Not (dates = "" Or dates = "Date") Then
For y = 2 To Range("B2").End(xlDown).Row
If (dates = (Cells(y, 2))) Then
For f = 2 To Range("f2").End(xlDown).Row
If ((TimeValue(Cells(y, 4).Text) >= TimeValue(Cells(f, 6).Text)) And (TimeValue(Cells(y, 4).Text) <= TimeValue(Cells(f, 7).Text))) Then
If (Cells(y, 3) = "Sunday") Then
' Cells(f, 12) = 1
Dim g As Integer
g = f - 2
MyArray1(g, 0) = 1
End If
If (Cells(y, 3) = "Monday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 1) = 1
End If
If (Cells(y, 3) = "Tuesday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 2) = 1
End If
If (Cells(y, 3) = "Wednesday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 3) = 1
End If
If (Cells(y, 3) = "Thursday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 4) = 1
End If
If (Cells(y, 3) = "Friday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 5) = 1
End If
If (Cells(y, 3) = "Saturday") Then
' Cells(f, 12) = 1
g = f - 2
MyArray1(g, 6) = 1
End If
End If
Next f
End If
Next y
For k = 0 To 7
For x = 0 To 23
Dim cellsval As Integer
Dim dayvals As Integer
cellsval = x + 2
dayvals = k + 9
Cells(cellsval, dayvals) = Cells(cellsval, dayvals) + MyArray1(x, k)
MyArray1(x, k) = 0
Next x
Next k
End If
Next
'For x = 2 To Range("H2").End(xlDown).Row
' For y = 2 To Range("A2").End(xlDown).Row
' If (Cells(y, 2) = Cells(x, 8)) Then
' If ((TimeValue(Cells(y, 4).Text) >= TimeValue(Cells(16, 6).Text)) And (TimeValue(Cells(y, 4).Text) <= TimeValue(Cells(16, 7).Text))) Then
' If (Cells(y, 3) = "Wednesday") Then
' Cells(x, 22) = 1
' End If
' End If
' End If
' Next y
'Next x
End Sub
Function RetTime(IntTime As Long) As Date
RetTime = TimeSerial(Int(IntTime / 10000), Int((IntTime Mod 10000) / 100), (IntTime Mod 100))
End Function
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number of unique elements
' If Count = False, the function returns a variant array of unique elements
Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
' Counter for number of unique elements
NumUnique = 0
' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
Exit For '(exit loop)
End If
Next i
AddItem:
' If not in list, add the item to unique list
If Not FoundMatch And Not IsEmpty(Element) Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
' Assign a value to the function
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function

Answer 1

I have taken the liberty of cleaning up your code a bit, I dropped a couple of comments in there to show you the changes and I have indented it properly.
Option Explicit
Private Sub CommandButton1_Click()
Dim dates As Variant, Array1() As Variant, MyArray1(24, 7) As Long, g As Long, MyWeekday As Variant, X As Long, K As Long, F As Long, Y As Long, Range1 As Range
MyWeekday = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
Range("I2:O25").ClearContents
Set Range1 = Range("B:B")
Array1 = UniqueItems(Range1, False)
For Each dates In Array1
If Not (dates = "" Or dates = "Date") Then
For Y = 2 To Range("B" & Rows.Count).End(xlUp).Row
If (dates = (Cells(Y, 2))) Then
For F = 2 To Range("f" & Rows.Count).End(xlUp).Row
If ((TimeValue(Cells(Y, 4).Text) >= TimeValue(Cells(F, 6).Text)) And (TimeValue(Cells(Y, 4).Text) <= TimeValue(Cells(F, 7).Text))) Then
For X = LBound(MyWeekday) To UBound(MyWeekday)
If (Cells(Y, 3) = MyWeekday(X)) Then
g = F - 2
MyArray1(g, X) = 1
End If
Next
End If
Next
End If
Next
For K = 0 To 7
For X = 0 To 23
Cells(X + 2, K + 9) = Cells(X + 2, K + 9) + MyArray1(X, K)
MyArray1(X, K) = 0
Next
Next
End If
Next
End Sub
Function RetTime(IntTime As Long) As Date
RetTime = TimeSerial(Int(IntTime / 10000), Int((IntTime Mod 10000) / 100), (IntTime Mod 100))
End Function
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number of unique elements
' If Count = False, the function returns a variant array of unique elements
Dim Unique() As Variant, Element As Variant, i As Long, FoundMatch As Boolean, NumUnique As Long
' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
' Counter for number of unique elements
NumUnique = 0
' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
Exit For '(exit loop)
End If
Next i
'AddItem - You don't need this as a GoTo heading you can jump to, keep it commented out
' If not in list, add the item to unique list
If Not FoundMatch And Not IsEmpty(Element) Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
' Assign a value to the function
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function
Please post try the code I posted and see if it does the same as your code did, if so then we can begin making the changes you need.