Оптимизируйте этот цикл поиска VBA в Excel

Я хочу оптимизировать следующий код, так как он очень медленный. Я использую код, найденный в этом ответе: https://stackoverflow.com/a/27108055/1042624

Тем не менее, он очень медленный, когда цикл через + 10k строк. Можно ли оптимизировать мой код ниже? Я попытался немного изменить его, но он не работает.

Sub DeleteCopy2() Dim LastRow As Long Dim CurRow As Long Dim DestLast As Long Dim strSheetName As String Dim arrVal() As Long Application.ScreenUpdating = False Application.Calculation = xlManual strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1 LastRow = Sheets("MatchData").Range("A" & Rows.Count).End(xlUp).Row DestLast = Sheets(strSheetName).Range("A" & Rows.Count).End(xlUp).Row ReDim arrVal(2 To LastRow) ' Headers in row 1 For CurRow = LBound(arrVal) To UBound(arrVal) If Not Sheets(strSheetName).Range("A2:A" & DestLast).Find(Sheets("MatchData").Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then Sheets("MatchData").Range("A" & CurRow).Value = "" Else End If Next CurRow Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub 

Можете ли вы попробовать это для меня? Я прокомментировал код, чтобы у вас не было проблем с его пониманием. Также проверьте, сколько времени потребуется для строк 10k +

логика

  1. Сохранять значения поиска в массиве 1
  2. Сохранять значения назначения в массиве 2
  3. Пропустите первый массив и проверьте, присутствует ли он во втором массиве. Если присутствует, очистите его
  4. Очистить значения поиска от листа1
  5. Вывести массив на лист1
  6. Сортировка Col A так, чтобы пробелы спускались.

Код

 Sub Sample() Dim wbMatch As Worksheet, wbDestSheet As Worksheet Dim lRow As Long, i As Long Dim MArr As Variant, DArr As Variant Dim strSheetName As String Dim rng As Range strSheetName = "Sheet2" '"Week " & IsoWeekNum(Format(Date)) - 1 '~~> Set your worksheets Set wbMatch = Sheets("MatchData") Set wbDestSheet = Sheets(strSheetName) '~~> Store search values in 1st array With wbMatch lRow = .Range("A" & .Rows.Count).End(xlUp).Row Set rng = .Range("A2:A" & lRow) MArr = rng.Value End With '~~> Store destination values in the 2nd array With wbDestSheet lRow = .Range("A" & .Rows.Count).End(xlUp).Row DArr = .Range("A2:A" & lRow).Value End With '~~> Check if the values are in the other array For i = LBound(MArr) To UBound(MArr) If IsInArray(MArr(i, 1), DArr) Then MArr(i, 1) = "" Next i With wbMatch '~~> Clear the range for new output rng.ClearContents '~~> Output the array to the worksheet .Range("A2").Resize(UBound(MArr), 1).Value = MArr '~~> Sort it so that the blanks go down .Columns(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _ MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal End With End Sub '~~> function to check is a value is in another array Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean Dim j As Long For j = 1 To UBound(arr, 1) On Error Resume Next IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0) On Error GoTo 0 If IsInArray = True Then Exit For Next End Function 

редактировать

Другой путь. На основе файла образца этот код запускается примерно через 1 минуту.

 Start : 8/4/2016 08:59:36 PM End : 8/4/2016 09:00:47 PM 

Логика :

Он использует CountIf для проверки дубликатов, а затем удаляет дубликаты с использованием .Autofilter

 Sub Sample() Dim wbMatch As Worksheet, wbDestSheet As Worksheet Dim lRow As Long Dim strSheetName As String Dim rng As Range Debug.Print "Start : " & Now strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1 '~~> Set your worksheets Set wbMatch = Sheets("MatchData") Set wbDestSheet = Sheets(strSheetName) '~~> Store search values in 1st array With wbMatch lRow = .Range("A" & .Rows.Count).End(xlUp).Row .Columns(2).Insert Set rng = .Range("B2:B" & lRow) lRow = wbDestSheet.Range("A" & wbDestSheet.Rows.Count).End(xlUp).Row rng.Formula = "=COUNTIF('" & strSheetName & "'!$A$1:$A$" & lRow & ",A2)" DoEvents rng.Value = rng.Value .Range("B1").Value = "Temp" 'Remove any filters .AutoFilterMode = False With .Range("A1:E" & lRow) 'Filter, offset(to exclude headers) and delete visible rows .AutoFilter Field:=2, Criteria1:=">0" .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete End With 'Remove any filters .AutoFilterMode = False .Columns(2).Delete End With Debug.Print "End : " & Now End Sub 

Похоже, @SiddarthRout и я работали параллельно …

Мой пример кода ниже выполняется менее чем за 2 секунды (оценка глазного яблока) почти на 12 000 строк.

 Option Explicit Sub DeleteCopy2() Dim codeTimer As CTimer Set codeTimer = New CTimer codeTimer.StartCounter Dim thisWB As Workbook Dim destSH As Worksheet Dim matchSH As Worksheet Set thisWB = ThisWorkbook Set destSH = thisWB.Sheets("Week 32") Set matchSH = thisWB.Sheets("MatchData") Dim lastMatchRow As Long Dim lastDestRow As Long lastMatchRow = matchSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row lastDestRow = destSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row '--- copy working data into memory arrays Dim destArea As Range Dim matchData As Variant Dim destData As Variant matchData = matchSH.Range("A1").Resize(lastMatchRow, 1) Set destArea = destSH.Range("A1").Resize(lastDestRow, 1) destData = destArea Dim i As Long For i = 2 To lastDestRow If Not InMatchingData(matchData, destData(i, 1)) Then destData(i, 1) = "" End If Next i '--- write the marked up data back to the worksheet destArea = destData Debug.Print "Destination rows = " & lastDestRow Debug.Print "Matching rows = " & lastMatchRow Debug.Print "Execution time = " & codeTimer.TimeElapsed & " secs" End Sub Private Function InMatchingData(ByRef dataArr As Variant, _ ByRef dataVal As Variant) As Boolean Dim i As Long InMatchingData = False For i = LBound(dataArr) To UBound(dataArr) If dataVal = dataArr(i, 1) Then InMatchingData = True Exit For End If Next i End Function 

Результат синхронизации моего кода (используя класс таймера из этого сообщения ):

 Destination rows = 35773 Matching rows = 23848 Execution time = 36128.4913359179 secs 
Interesting Posts

Получить значение столбца из 2 строк

Скопируйте данные из подмножества рабочих листов в рабочую книгу и вставив их в основной рабочий лист, не считая стандартных этапов

Одновременно пишите pandas DataFrame в xlsx

Использование текущей SUMIF-строки в критериях

Лист изменения уязвимости в excel с использованием apache poi api

Отменить таблицу в листе Excel перед сохранением – как txt-файл с разделителями табуляции

Ошибка при замене писем на другие

Условное форматирование, не отображающее основные ячейки на компьютере

Исключение: преобразование из строки «<текст>» для ввода «Целое» недействительно

Заполнение переменной со всеми значениями в строке

Импортировать книгу Excel в базу данных выполнения

C # Вставить содержимое буфера обмена в рабочий лист Excel

Ширина переменной ширины в Python

Отображение самых больших «n» элементов из набора данных в Excel

Копирование из ячейки, в новый комментарий ниже и переход к повторению

Давайте будем гением компьютера.