Добрый день! Прошу помощи! Есть макрос, который удаляет строки не попадающие под условия, но проблема в том, что они удаляются построчно, а это очень долго, т.к. строк, для анализа, может быть до 1 млн. Перечитал несколько подобных тем, в т.ч. и по ссылке с другого ресурса, которую выкладывали здесь. Понимаю, что можно "прогнать" строки через цикл For Each...Next, но не могу понять как сделать это с моим кодом. Макросы начал изучать не давно, поэтому прошу помочь!
Код
Sub Test()
Dim Картотека As Worksheet
Set Картотека = Worksheets("Картотека")
Dim FinalRow As Long
Dim dic1 As New Dictionary
FinalRow = Картотека.Cells(Rows.Count, 1).End(xlUp).Row
dic1.Add CStr("0059_Абонентский комплект"), 1
dic1.Add CStr("0060_АТС электронная"), 1
dic1.Add CStr("0065_Головная станция кабельного ТВ"), 1
dic1.Add CStr("0068_Домовой узел"), 1
dic1.Add CStr("0090_Магистральный узел"), 1
dic1.Add CStr("0105_Точка-многоточка"), 1
dic1.Add CStr("0123_Узел доступа телематических служб"), 1
dic1.Add CStr("0155_АТС аналоговая"), 1
dic1.Add CStr("0158_Оборудование РРС в составе АБК"), 1
dic1.Add CStr("0178_Оборудование БШПД в составе АБК"), 1
dic1.Add CStr("0271_Точка доступа частного сектора"), 1
For a = 2 To FinalRow
If dic1.Exists(CStr(Картотека.Cells(a, 48))) = False Then
Картотека.Rows(a).Delete Shift:=xlUp
a = a - 1
FinalRow = FinalRow - 1
If FinalRow < a Then
Exit For
End If
End If
Next a
End Sub
Добрый день. В принципе, алгоритм довольно шустрый, основная потеря времени, кмк, это при отрисовке изменений (удалении строк). Поэтому предлагаю после объявлений переменных вставить инструкцию отключения обновления экрана, а в конце включения его обратно. Типа:
Код
Dim dic1 As New Dictionary
Application.ScreenUpdating=False
'тут идет код...
Application.ScreenUpdating=True
End Sub
Sub Test()
Dim arrKey(), arr(), arrNew()
Dim lRow&, I&, J&, N&, iKey, iTemp
Dim myRng As Range
arrKey = Array("0059_Абонентский комплект", "0060_АТС электронная", "0065_Головная станция кабельного ТВ", _
"0068_Домовой узел", "0090_Магистральный узел", "0105_Точка-многоточка", _
"0123_Узел доступа телематических служб", "0155_АТС аналоговая", "0158_Оборудование РРС в составе АБК", _
"0178_Оборудование БШПД в составе АБК", "0271_Точка доступа частного сектора")
With Worksheets("Картотека")
Set myRng = .Range(.Cells(2, 1), Cells(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(2, .Columns.Count).End(xlToLeft).Column))
arr = myRng.Value
End With
ReDim arrNew(1 To UBound(arr, 1), 1 To UBound(arr, 2))
With CreateObject("Scripting.Dictionary")
For Each iKey In arrKey
iTemp = .Item(iKey)
Next
For I = 1 To UBound(arr, 1)
If .Exists(arr(I, 48)) Then
N = N + 1
For J = 1 To UBound(arr, 2)
arrNew(N, J) = arr(I, J)
Next
End If
Next
End With
Application.ScreenUpdating = False
myRng.ClearContents
Worksheets("Картотека").Range("A2").Resize(N, UBound(arrNew, 2)) = arrNew
Application.ScreenUpdating = True
End Sub
Согласие есть продукт при полном непротивлении сторон
Sub Test()
Dim arrKey(), arr()
Dim lRow&, I&, iKey, iTemp
Dim myRng As Range, delRows As Range
arrKey = Array("0059_Абонентский комплект", "0060_АТС электронная", "0065_Головная станция кабельного ТВ", _
"0068_Домовой узел", "0090_Магистральный узел", "0105_Точка-многоточка", _
"0123_Узел доступа телематических служб", "0155_АТС аналоговая", "0158_Оборудование РРС в составе АБК", _
"0178_Оборудование БШПД в составе АБК", "0271_Точка доступа частного сектора")
With Worksheets("Картотека")
Set myRng = .Range(.Cells(2, 1), Cells(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(2, .Columns.Count).End(xlToLeft).Column))
arr = myRng.Value
End With
ReDim arrNew(1 To UBound(arr, 1), 1 To UBound(arr, 2))
With CreateObject("Scripting.Dictionary")
For Each iKey In arrKey
iTemp = .Item(iKey)
Next
For I = 1 To UBound(arr, 1)
If .Exists(arr(I, 48)) Then
If delRows Is Nothing Then
Set delRows = myRng.Rows(I)
Else
Set delRows = Union(delRows, myRng.Rows(I))
End If
End If
Next
End With
Application.ScreenUpdating = False
If Not delRows Is Nothing Then delRows.Delete
Application.ScreenUpdating = True
End Sub
Согласие есть продукт при полном непротивлении сторон
Строки с этими значениями, наоборот, должны остаться, остальное удалить
Код
arrKey = Array("0059_Абонентский комплект", "0060_АТС электронная", "0065_Головная станция кабельного ТВ", _
"0068_Домовой узел", "0090_Магистральный узел", "0105_Точка-многоточка", _
"0123_Узел доступа телематических служб", "0155_АТС аналоговая", "0158_Оборудование РРС в составе АБК", _
"0178_Оборудование БШПД в составе АБК", "0271_Точка доступа частного сектора")
With Worksheets("Картотека")