How to prevent Repetitive Looping and Data Duplication

问题

This is currently the code that I am using. I embedded the code inside a change event when a cell within a range changes. But, every time I do change a cell within the range the entire loop starts from the top of the row and inserts the data in the destination cells repetitively. Is there a way that the loop doesn't post the data that is already at the destination? I guess I need the loop not to loop a cell that it already looped on the INFO INPUT sheet.

The change event triggers the macro when a cell changes in the range between D2:D30. The macro searches for data in the E column. I need the macro to look only in the 'E' column for the data and not in the rest of the table on the INFO INPUT sheet.

Sub worksheet_Change(ByVal target As Range)

If Not Application.Intersect(target, Range("D2:D30")) Is Nothing Then
    Application.EnableEvents = False
    Dim wsInfoSheet As Worksheet
    Dim wsProofSheet As Worksheet
    Dim lngLastRow As Long
    Dim r As Long
    Dim sAcct As String
    Dim lngNextRow As Long
    Dim sLongName As String

    Dim arrRef() As Variant
    Dim arrNames() As String
    Dim i As Long
    Dim lngRowInNames As Long
    Dim lngFoundName As Long

    Set wsInfoSheet = ThisWorkbook.Sheets("Info Input")
    Set wsProofSheet = ThisWorkbook.Sheets("Proof")

    'Will be used in the Proof sheet
    lngNextRow = 4                           ' waiting to adjust to normal table format

    arrRef = wsProofSheet.Range("A199:L79000").Value
    ReDim arrNames(1 To UBound(arrRef, 1) + 1, 1 To 2)

    With wsInfoSheet

        lngLastRow = .Cells(.Rows.Count, "E").End(xlUp).Row

        lngRowInNames = 1
        For r = 2 To lngLastRow
            sAcct = .Cells(r, "E")
            'lookup for sAcct in arrRef
            For i = 1 To UBound(arrRef, 1)
                If arrRef(i, 1) = sAcct Then
                    sLongName = arrRef(i, 12) '(row i, column 2 from arrRef)
                    arrNames(lngRowInNames, 1) = sLongName
                    arrNames(lngRowInNames, 2) = lngNextRow
                    lngRowInNames = lngRowInNames + 1
                    Exit For
                End If
            Next
            'lookup for sLongName in arrNames
            For i = 1 To UBound(arrNames, 1)
                If arrNames(i, 1) = sLongName Then
                    lngFoundName = i
                    Exit For
                End If
            Next

            'if the name is new
            If arrNames(lngFoundName + 1, 1) = "" Then
                wsProofSheet.Cells(lngNextRow, "E") = sAcct
                wsProofSheet.Cells(lngNextRow, "B") = sLongName
                lngNextRow = lngNextRow + 8  ' would be nicer to just add one row (see  first note)
                'if the name already exists
            Else
                wsProofSheet.Cells(arrNames(lngFoundName, 2), wsProofSheet.Cells(arrNames(lngFoundName, 2),       wsProofSheet.Columns.Count).End(xlToLeft).Column + 3) = sAcct
            End If

        Next                                 'r

    End With
    Application.EnableEvents = True
End If


End Sub

回答1:

I removed some of variables and introduced some others. Overall, reworked the code quite much. Most of the problem was on the longest line. It looks like everything works on my dummy data. Hope you will be able to tweak your Worksheet_Change event.

Sub Worksheet_Change(ByVal Target As Range)

  If Not Application.Intersect(Target, Range("D2:D30")) Is Nothing Then
    Application.EnableEvents = False

    Dim wsProofSheet As Worksheet
    Dim sAcct As String
    Dim sLongName As String
    Dim rngRef As Range
    Dim arrRef() As Variant
    Dim i As Long
    Dim lngFoundRow As Long
    Dim rngRowLastCell As Range
    Dim blnAccNumberExists As Boolean

    Set wsProofSheet = ThisWorkbook.Sheets("Proof")
    Set rngRef = wsProofSheet.Range("A199:L79000")
    arrRef = rngRef.Value
    sAcct = Me.Cells(Target.Row, "E").Value
    'lookup for sAcct in arrRef
    For i = 1 To UBound(arrRef, 1)
      If arrRef(i, 1) = sAcct Then
        sLongName = arrRef(i, 12)
        Exit For
      End If
    Next
    'lookup for sLongName in Proof sheet, column B
    For i = 2 To rngRef.Row - 1
      If wsProofSheet.Range("B" & i).Value = sLongName Then
        lngFoundRow = wsProofSheet.Range("B" & i).Row
        Exit For
      End If
    Next
    'if Account Name already exists:
    If lngFoundRow > 0 Then
      Set rngRowLastCell = wsProofSheet.Cells(lngFoundRow, wsProofSheet.Columns.Count).End(xlToLeft)
      'checking if account number exists
      blnAccNumberExists = False
      For i = 1 To rngRowLastCell.Column
        If wsProofSheet.Cells(lngFoundRow, i).Value = sAcct Then blnAccNumberExists = True
      Next
      'if account number already exists:
      If blnAccNumberExists Then
        ' do nothing
      'if account number does not exist:
      Else
        If rngRowLastCell.Column = 2 Then rngRowLastCell.Offset(, 3).Value = sAcct
        If rngRowLastCell.Column > 2 Then rngRowLastCell.Offset(, 2).Value = sAcct
      End If
    'if Account Name does not exist:
    Else
      For i = 2 To rngRef.Row - 1
        If wsProofSheet.Cells(i, "B").Value = "Account Name" _
         And wsProofSheet.Cells(i + 2, "B").Value = "" Then
          wsProofSheet.Cells(i + 2, "B").Value = sLongName
          wsProofSheet.Cells(i + 2, "E").Value = sAcct
          Exit For
        End If
      Next
    End If

    Application.EnableEvents = True
  End If

End Sub

来源：https://stackoverflow.com/questions/59884884/how-to-prevent-repetitive-looping-and-data-duplication