Need a way to input data in specific cells with Excel VBA

Question

Trying to solve for a loop that reads the account numbers in column 'E' on the "Info sheet" starting from 'E2' and takes that number and inputs it in the first row containing an empty white cell on the "Proof" sheet ('E4') under the account number section. Once the number is placed there, the "long name" (found in the table on the 200th row) associated with the account number in the cell 'E4' appears in the first empty white cell ('B4') under the account name section. Then, the loop continues and reads the next cell ('E3') on the "Input sheet", and if that account number belongs to the same name, place that number in the next white cell ('G4') on the "Proof" sheet. If the account number is not associated with the account name in cell 'B4', put it in the next line containing an empty white cell 'E12' and assign the appropriate name for that number in cell under account name in cell 'B12' and continue down the list in column 'E' on the Info sheet and repeat the process until all the account numbers on the first sheet are complete and all the appropriate account numbers are on the row that has the appropriate 'long name' for those account numbers.

How can I put all the accounts linked to the account name on the same row in the specific white cells without posting them twice on the same row?

This is the code I have:

Sub loopything()


Dim infoSheet As Worksheet, proofSheet As Worksheet, refRange As         Range, lastRow As Long, r As Long
Dim acct As String, foundAcct As Range, nextRow As Long
Set infoSheet = ThisWorkbook.Sheets("Info Sheet")
Set proofSheet = ThisWorkbook.Sheets("Proof")

With proofSheet
nextRow = 4 ' waiting to adjust to normal table format
End With

With proofSheet

Set refRange = .Range("A200:L79000")

End with 

With InfoSheet

lastRow = 30 ' .cells(.rows.count, "E").end(xlup).row

For r = 2 To lastRow

acct = .Cells(r, "E")
Set foundAcct = refRange.Find(what:=acct)
longname = foundAcct.Offset(0, 1)


proofSheet.Cells(nextRow, "E") = acct
proofSheet.Cells(nextRow, "B") = longname
nextRow = nextRow + 8   ' would be nicer to just add one row (see  first note)

Next r

End With

End Sub

Take a look at the snippets for reference.

Info Input Sheet

Proof Sheet

The code is currently doing this:

See how in the practice examples, which is supposed to mimic the real sheets, the name appears on multiple rows with their respective account numbers when they should be appearing on the same row under the same name with all the account numbers on one row.

Answer 1

Try this. I did not use find method, because you are likely to do many searches on the same dataset. So I loaded it into an array which will be searched instead of a range object (it is faster).

One thing to have in mind - before running it, you need to DELETE all the account numbers in Proof sheet.

Sub loopything()

  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 Sheet")
  Set wsProofSheet = ThisWorkbook.Sheets("Proof")

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

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

  With wsInfoSheet

    lngLastRow = 30 ' .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, 2) '(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

End Sub

Answer 2

So, 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, I was interested in knowing if there is a way that the code can ensure that if the account number is already in a cell it should not post the same number again in the next cell on the same row. Meaning, every time there is a change in the range, the macro runs anew and places the numbers repetitively. I assume I need to put a reset somewhere in the code but I do not know how or where.

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

Dim iCell As Range
If Not Application.Intersect(target, Range("A2:A30")) Is Nothing Then
Application.EnableEvents = False
For Each iCell In Range("A2:A30")
    If iCell.Address = target.Address Then
        Range("C" & iCell.Row).ClearContents
        Range("D" & iCell.Row).ClearContents
        Range("I" & iCell.Row).ClearContents
    End If
Next iCell

End If
Application.EnableEvents = True
End Sub