VBA to insert text based on cell in range

[Burt_100]

I am looking code to insert text into a column based on the value in a specified range, Currently I am using the following vlookup code =VLOOKUP(N3,$AM$2:$AN$8,2,0) but have been finding it very slow when using a macro for the rest of the workbook, I have attached a copy of the workbook showing the code and what I am trying to achieve.
Thanks in advance

[mehmetcik]

Try this formula instead:-

=INDEX(AN$1:AN$8,MATCH(N2,AM$1:AM$8,0),1)

[xladept]

Hi Burt,

This works for just the one contact as per your sample:

Sub BurtITCR(): Dim r As Long, CNo As String, Col As Long
Dim wr As Worksheet: Set wr = Sheets("Reminders"): Col = 14
    With CreateObject("Scripting.Dictionary")
For r = 2 To wr.Range("AM" & Rows.count).End(xlUp).Row
CNo = wr.Range("AM" & r): .Item(CNo) = wr.Range("AN" & r)
Next r
For r = 2 To wr.Range("N" & Rows.count).End(xlUp).Row
    If Not IsError(wr.Range("N" & r)) Then
        CNo = wr.Range("N" & r)
If .Exists(CNo) Then wr.Range("AB" & r) = .Item(CNo)
    End If
  Next r
    End With
End Sub

[Burt_100]

xladept, thanks that works great for the one as per the example but is it possible to make it work for all 5 possible contacts in columns N, P, R, T, V.
Thanks and sorry for not being clear.
Johnny

[xladept]

Hi Johnny,

Try this:

Sub BurtITCR(): Dim r As Long, CNo As String, Col As Long, n As Long
Dim wr As Worksheet: Set wr = Sheets("Reminders")
    With CreateObject("Scripting.Dictionary")
For r = 2 To wr.Range("AM" & Rows.count).End(xlUp).Row
CNo = wr.Range("AM" & r): .Item(CNo) = wr.Range("AN" & r)
Next r
For n = 0 To 4: Col = 14 + 2 * n
For r = 2 To wr.Range(Chr(Col + 64) & Rows.count).End(xlUp).Row
    If Not IsError(wr.Cells(r, Col)) Then
        CNo = wr.Cells(r, Col)
If .Exists(CNo) Then wr.Cells(r, 28 + n) = .Item(CNo)
    End If
  Next r
Next n
    End With
End Sub