Блог

У меня есть электронная таблица с приблизительно 45 000 строками. В настоящее время я перебираю столбец и нацеливаюсь на любые ячейки со значением 0. Эти номера строк сохраняются в массиве. Затем я перебираю этот массив и изменяю другую ячейку на основе значения массива. У меня есть 5000 строк со значениями, которые необходимо переназначить, и на выполнение этого сегмента кода уходит более часа (сохранение номеров строк в массив занимает всего несколько секунд). Есть идеи о том, как заставить код работать быстрее? Вот код:

 'Initialize array
Dim myArray() As Variant
Dim x As Long

'Looks for the last row on the "Dates" sheet
Dim lastRow As Long
With ThisWorkbook.Sheets("Dates")
    lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row   1
End With

Dim i As Integer
i = 2

Dim uCounter As Integer
'Loop through all the dates on the "Dates" sheet
While i <= lastRow
    'Each date has a counter next to it
    uCounter = Worksheets("Dates").Range("B" amp; i).Value
    Dim uDate As String
    'Store the date as a string
    uDate = Worksheets("Dates").Range("C" amp; i).Value
    Dim startRow As Long, endRow As Long
    'Finds the first and last instance of the date on the CERF Data page (45,000 rows)
    With Sheets("CERF Data")
        startRow = .Range("AN:AN").Find(what:=uDate, after:=.Range("AN1"), LookIn:=xlValues).Row
        endRow = .Range("AN:AN").Find(what:=uDate, after:=.Range("AN1"), LookIn:=xlValues, searchdirection:=xlPrevious).Row
    End With

    Dim j As Long
    For j = startRow To endRow
        'If the cell in column BB is 0, and the counter is above 0 save row number to array, j being the variable representing row number
        If Sheets("CERF Data").Range("BB" amp; j).Value = 0 And uCounter > 0 Then
            'save row number to array
            ReDim Preserve myArray(x)
            myArray(x) = j
            x = x   1
            'decrement counter by 1
            uCounter = uCounter - 1
        End If
        If uCounter = 0 Then Exit For
    Next j
i = i   1
Wend

Dim y As Long
'Loop through the array and assign a value of 2 to all the rows in the array for column AS
For y = LBound(myArray) To UBound(myArray)
    Sheets("CERF Data").Range("AS" amp; myArray(y)).Value = 2
Next y
  

Спасибо!

Без дополнительной информации это то, что я могу вам предоставить:

Просто 1 цикл по всем строкам, один раз, проверяя, находится ли значение в столбце BB = 0 и дата в пределах вашего диапазона дат:

 Option Explicit
Sub Test()

    Dim arr, i As Long, DictDates As Scripting.Dictionary

    arr = ThisWorkbook.Sheets("CERF Data").UsedRange.Value
    Set DictDates = New Scripting.Dictionary 'You need the Microsoft Scripting Runtime Reference for this to work

    'Create a dictionary with all the dates you must check
    With ThisWorkbook.Sheets("Dates")
        LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
        For i = 2 To LastRow
            If Not DictDates.Exists(CDate(.Cells(i, 3))) Then DictDates.Add CDate(.Cells(i, 3)), 1
        Next i
    End With

    'Only one loop through the whole array
    For i = 1 To UBound(arr)
        If arr(i, 54) = 0 And DictDates.Exists(CDate(arr(i, 40))) Then  'check your 2 criterias, date and value = 0
            arr(i, 45) = 2 'input the value 2 on the column "AS"
        End If
    Next i


    ThisWorkbook.Sheets("CERF Data").UsedRange.Value = arr

End Sub