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

这是使用变量数组的代码重构。

Offset替换为数组列中的索引。只需确保数组足够宽即可包含要偏移的所有列（在数组加载行中用.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

我如何优化代码，所以vba不会崩溃？

1 个答案: