Excel vba中的性能问题和错误
我已经创build了一个代码，从一个充满了date的列中获得唯一的值，并从唯一的列中比较星期天或星期一或星期二等，以及是否在两个时间戳之间[2:00:00上午2点59分59秒]我增加，但如果在相同的date例如2014年1月5日，它又落在两个时间戳[凌晨2:00:00 – 上午2:59:59]我不应该增量和如果在相同的date落在另一个时间戳，它应该只增加一次。
它正在工作50行-100行，但它是悬挂行200K。
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 我冒昧地清理了一下你的代码，我在那里放了几条评论来向你展示这些改变，并且正确地缩进了它。
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
请发帖尝试我发布的代码，看看它是否与你的代码一样，如果是的话，那么我们可以开始做你需要的更改。