CODEWITHSUNDEEP
vbaexcel
krishna
krishna

Reputation: 83

Performance issue and error in Excel vba

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

Upvotes: 0

Views: 78

Answers (1)

Dan Donoghue
Dan Donoghue

Reputation: 6216

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.

Upvotes: 1

Related Questions