How to prevent Repetitive Looping and Data Duplication

[mamamia93]

This is currently the code that I am using. I embedded the code inside a change event when a cell within a range changes in runs the loop searching for numbers in the range and posting them in another sheet. But, every time I make a change to a cell within the range the entire loop starts from the top of the column and inserts the data in the destination cells repetitively and multiple times resulting in having the same data multiple times on the sheet. Is there a way to change the code below to prevent the loop from searching the column once the loop already searched a specific cell within the range?


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

 

[Snakehips]

@mamamia93
From your post, I certainly don't fully understand what data set up you have nor what you want to achieve nor exactly how the code is misbehaving.

The only thing that occurs to me is that you have no conditional exit from the For - Next loop of r
Consequently it will always loop 2 to lngLastRow
Is that your intention or is that the problem ?

 

[mamamia93]

So the code is built to take data (account numbers) from column 'E' between E2:E30 from the "INFO INPUT" sheet and placing it in the "PROOF" sheet in the white cells. The problem is that I wanted to automate the process and trigger the macro whenever I input data in the cells in column 'E'. So, when I input the data in a cell in the column the loop runs and copies and pastes that in the white cells in the "PROOF" sheet. The problem is that anytime I input data anywhere in the column it runs the macro from the beginning causing it to copy previous numbers that were already copied and duplicating them in the "PROOF" sheet. So, I got the automatic process going, but it's constantly running the loop from the beginning of the column and duplicating the numbers. See the snippets below.

 

[DataBlake]

if you want to exit a loop you have a few options
1. A do until loop

Do Until Loop in Excel VBA

Learn how to use the Do Until Loop in Excel VBA. Code placed between Do Until and Loop will be repeated until the part after Do Until is true.

www.excel-easy.com

you can have something like

do until arrRef(i, 1) = sAcct
i = i + 1
if i > UBound(arrRef, 1) then goto exloop
loop
exloop:

2. the same thing but wih your for loop *note you generally want to close a for loop with the variable name like so

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
goto exloop
End If
Next i

exloop:

i dont have the time today to test out your entire workbook scenario but using goto is very effective for what you want as well as deciding which kind of loop is best for you
so tl:dr if conditions are met then goto customname
then add customname outside the loop with ":"

GoTo statement (VBA)

Office VBA reference topic

docs.microsoft.com

 

[Snakehips]

You mention wanting to react to changes in column E yet your code runs if the change is columnD ?
Do you want it to run and transfer just one changed row at a time?
Is the below code more like what you are after?

See the comment lines with ********where I am querying and suggesting possible change.

Sub Worksheet_Change(ByVal target As Range)
'****??? Only Run if Change is column D  ??????? or E??? below is D
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

'******  Changed row number = Target row so....
r = target.Row
'****** Not wanting to loop as interested in single row only?
'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

'*******Single row sorted so no need to loop r ????
'Next 'r
'***************
End With
Application.EnableEvents = True
End If

End Sub

Hope that helps.

 

[mamamia93]

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. I am not understanding what you are saying with the 'r'. I designated the 'r' variable to search the second row in the 'E' column and go down from there until the last row with data in the 'E' column. Also, I do not think it should be r= target.row because it is only taking one number from the list. I need all the numbers.