Как я могу оптимизировать код, чтобы VBA не Cra sh?

Question

У меня есть следующий код, и последняя часть кода всегда делает VBA go неактивным. Как я могу адаптировать код, чтобы он был более эффективным?

Есть ли более умный способ работы с переменными l oop? потому что у меня есть i и e, чтобы отследить, где я в списке, и снова запустить l oop для if l oop

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.

Offset заменяется индексом в столбцах массива. Просто убедитесь, что массив достаточно широк, чтобы включить все столбцы, в которые вы хотите сместить (достигается с помощью .Resize(, 5) в строке загрузки массива).

Примечание: я не пытался понять вашу логику c, но просто преобразовал диапазон значений в массивы. Вам нужно будет проверить, соответствуют ли результаты ожидаемым

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