Как предотвратить повторяющиеся циклы и дублирование данных

Question

Это код, который я сейчас использую. Я встроил код в событие изменения, когда ячейка в диапазоне изменяется. Но каждый раз, когда я меняю ячейку в пределах диапазона, весь l oop начинается с вершины строки и периодически вставляет данные в ячейки назначения. Есть ли способ, которым l oop не публикует данные, которые уже находятся в месте назначения? Я думаю, мне нужно l oop, а не l oop ячейка, которую она уже зациклила на листе INFO INPUT.

Событие изменения запускает макрос, когда ячейка изменяется в диапазоне между D2: D30 , Макрос ищет данные в столбце E. Мне нужно, чтобы макрос просматривал данные только в столбце 'E', а не в остальной таблице таблицы INFO INPUT.

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

Answer 1

Я удалил некоторые переменные и представил некоторые другие. В целом, код переработан довольно много. Большая часть проблемы была на самой длинной линии. Похоже, все работает на моих фиктивных данных. Надеюсь, вы сможете настроить ваше событие Worksheet_Change.

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 wsRef 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 wsRef = ThisWorkbook.Sheets("SHEET1")
    Set rngRef = wsRef.Range("A1: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 wsProofSheet.Cells(wsProofSheet.Rows.Count, "B").End(xlUp).Row
      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 wsProofSheet.Cells(wsProofSheet.Rows.Count, "B").End(xlUp).Row
        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