如何防止重复循环和数据重复 [英] How to prevent Repetitive Looping and Data Duplication

问题描述

这是当前正在使用的代码.当范围内的单元格发生更改时，我将代码嵌入了change事件中.但是，每次我在该范围内更改一个单元格时，整个循环便从该行的顶部开始，并将数据重复地插入到目标单元格中​​.有没有一种方法可以使循环不发布目的地中已经存在的数据?我想我需要循环而不是循环它已经在INFO INPUT表上循环的单元格.

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.

当单元格在D2:D30之间的范围内更改时，更改事件将触发宏.宏在E列中搜索数据.我需要该宏仅在"E"列中查找数据，而不在INFO INPUT表上表的其余部分中查找.

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

推荐答案

我删除了一些变量，并介绍了其他一些变量.总体而言，对代码进行了相当多的重做.大部分问题都在最长的线上.看起来一切都对我的伪数据起作用.希望您能够调整您的Worksheet_Change事件.

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 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

这篇关于如何防止重复循环和数据重复的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！