在Excel中优化这个VBA查找循环

我想优化下面的代码，因为它非常慢。 我正在使用这个答案中find的代码： 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 

Answer 1

你可以试试这个吗？ 我已经评论了代码，以便您不会理解它。 还要检查10k +行需要多less时间

逻辑

1. 将search值存储在数组1中
2. 将目标值存储在数组2中
3. 循环遍历第一个数组，并检查它是否出现在第二个数组中。 如果存在，清除它
4. 清除sheet1中的search值
5. 将数组输出到sheet1
6. 将列Asorting，以便空白消失。

码

 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删除重复.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 

Answer 2

看起来像@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