如何优化代码，使vba不会崩溃

Question

我有以下代码，代码的最后一部分总是使vba处于非活动状态。如何调整代码，使其更高效？

有没有更聪明的方法来操作循环中的变量？因为我有i和e，为了跟踪我在列表中的位置，并再次启动if循环的循环

Sub Run()
Dim aRng As Range
Set aRng = Range("A4:A" & Cells(Rows.Count, "A").End(xlUp).Row)
'Copy Arng to Col C, and remove duplicates
With aRng
.Copy .Offset(, 2)
.Offset(, 2).RemoveDuplicates Columns:=1, Header:=xlNo
With aRng.Offset(, 2)
If WorksheetFunction.CountA(.Cells) > 0 Then .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp
End With
End With
'Define and Set rng
Dim cRng As Range: Set cRng = Range("C4:C" & Cells(Rows.Count, "C").End(xlUp).Row)
With cRng
With .Offset(, 1) 'Use offset to insert formula to count duplicates
.FormulaR1C1 = "=countif(C[-3]:C[-3] ,R[]C[-1])"
.Value = .Value 'Use .Value = .Value to remove the formula
End With
End With
'Remove all characters before "Domain" and put in Col E
With cRng
For Each i In cRng
i.Offset(, 2).Value = "=RIGHT(RC[-2],LEN(RC[-2])-FIND(""@"",(SUBSTITUTE(RC[-2],""_"",""@"",LEN(RC[-2])-LEN(SUBSTITUTE(RC[-2],""_"",""""))-1)),1))"
.Value = .Value
'Test for "DES_" and if True write "DES" or if False write "Not DES" in Col F
If Left(i.Value, 4) = "DES_" Then
i.Offset(, 3).Value = "DES"
Else: i.Offset(, 3).Value = "Not DES"
End If
Next i
End With

这部分使vba有一个困难的时间

Dim a As String
With cRng
For Each i In cRng
For Each e In cRng
If Left(i.Value, 4) <> "DES_" Then
a = i.Offset(, 2).Value
If Left(e.Value, 4) = ("DES_") And Right(e.Value, Len(a)) = a Then
i.Offset(, 4).Value = "Matching DES found"
e = Empty
GoTo nextI
Else
i.Offset(, 4).Value = "unique"
GoTo nextE
End If
Else
GoTo nextI
End If
nextE:
Next e
nextI:
Next i
End With
End Sub

Answer 1

下面是使用Variant Arrays的代码重构。

将CCD_ 1替换为对数组列的索引。只需确保数组足够宽，可以包括要偏移到的所有列(使用数组加载行中的.Resize(, 5)实现(。

注意：我没有试图理解您的逻辑，只是简单地将范围引用转换为数组。您需要验证结果是否符合您的预期

Option Explicit ' Top line in module
Sub Run()
Dim ws As Worksheet
Dim aRng As Range
Dim rw As Long
Set ws = ActiveSheet
Set aRng = ws.Range("A4:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
'Copy Arng to Col C, and remove duplicates
With aRng
.Copy .Offset(, 2)
.Offset(, 2).RemoveDuplicates Columns:=1, Header:=xlNo
With aRng.Offset(, 2)
If WorksheetFunction.CountA(.Cells) > 0 Then .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlShiftUp
End With
End With
'Define and Set rng
Dim cRng As Range
Dim cData As Variant
Set cRng = Range("C4:C" & Cells(Rows.Count, "C").End(xlUp).Row)
cData = cRng.Resize(, 5).Value2 '<~~ Copy 5 Columns to Variant Array
With cRng
With .Offset(, 1) 'Use offset to insert formula to count duplicates
.FormulaR1C1 = "=countif(C[-3]:C[-3] ,R[]C[-1])"
.Value = .Value 'Use .Value = .Value to remove the formula
End With
End With
'Remove all characters before "Domain" and put in Col E
With cRng.Offset(, 2)
.FormulaR1C1 = "=RIGHT(RC[-2],LEN(RC[-2])-FIND(""@"",(SUBSTITUTE(RC[-2],""_"",""@"",LEN(RC[-2])-LEN(SUBSTITUTE(RC[-2],""_"",""""))-1)),1))"
.Value = .Value
End With
'With cRng
'For Each i In cRng
For rw = 1 To UBound(cData, 1)

'Test for "DES_" and if True write "DES" or if False write "Not DES" in Col F
If Left(cData(rw, 1), 4) = "DES_" Then
cData(rw, 4) = "DES"
Else
cData(rw, 4) = "Not DES"
End If
Next
'End With
Dim a As String
Dim rw2 As Long
'With cRng
'For Each i In cRng
For rw = 1 To UBound(cData, 1)
'For Each e In cRng
For rw2 = 1 To UBound(cData, 1)
If Left(cData(rw, 1), 4) <> "DES_" Then
a = cData(rw, 3)
If Left(cData(rw2, 1), 4) = ("DES_") And Right(cData(rw2, 1), Len(a)) = a Then
cData(rw, 5) = "Matching DES found"
cData(rw, 1) = Empty
Exit For
'GoTo nextI
Exit For
Else
cData(rw, 5) = "unique"
'GoTo nextE
End If
Else
'GoTo nextI
Exit For
End If
'nextE:
Next
'nextI:
Next
'End With
' Put array back on sheet
cRng.Resize(, 5) = cData
End Sub