Preventing duplicates when adding records to list

  • Thread starter Thread starter bobwilson
  • Start date Start date
B

bobwilson

I use the below Code to copy data from specific cells to populate a
contact list. I'm trying to make the code review the existing customer
list base on Name to ensure that it is not adding a duplicate record
and if so I want to exit the macro before inserting data.

Sub newcontact()

With Application
ScreenUpdating = False

c_Database = "Contact List"

Dim indexnrcl As Integer
Dim namecl As String
Dim phonecl As String
Dim faxcl As String
Dim emailcl As String
Dim datecl As String
Dim commcl As String
Dim pstcl As String
Dim gstcl As String

indexnrcl = ActiveSheet.Range("b134")
namecl = ActiveSheet.Range("f105")
phonecl = ActiveSheet.Range("c106")
faxcl = ActiveSheet.Range("f106")
emailcl = ActiveSheet.Range("c107")
datecl = ActiveSheet.Range("c108")
commcl = ActiveSheet.Range("f108")
pstcl = ActiveSheet.Range("c109")
gstcl = ActiveSheet.Range("f109")

With Sheets(c_Database).Range("A" & indexnrcl + 1)
If Val(.Value) > 0 Then
MsgBox "A Record with Number " & indexnr & " already exists!"

Else

Value = indexnrcl
Offset(0, 1) = namecl
Offset(0, 2) = phonecl
Offset(0, 3) = faxcl
Offset(0, 4) = emailcl
Offset(0, 5) = datecl
Offset(0, 6) = commcl
Offset(0, 7) = pstcl
Offset(0, 8) = gstcl

End If
End With

End With


End Sub
 
The following is the suggested basic mechanics with most of your code ommitted:

Set ws = Sheets("Contact List")
'Establish range of all existing contact names
Set r = ws.Range(ws.Cells(2, 2), ws.Cells(Rows.Count, 2).End(xlUp))
namecl = ActiveSheet.Range("f105")
'Search for namec1 in existing list of contact names
If Not r.Find(namecl) Is Nothing Then
msg = "A client entry for " & namecl & " already exists. Cannot add
contact. "
MsgBox msg, vbCritical, "Add New Contact"
Else
'Your code here

End If

Suggested rewrite using a Type construct follows. I find a Type construct
useful for this sort of thing for readability. This is intended for
illustration purposes only and should be tested on a copy of your data. Some
adjustment is very likely required.

Type CInfo
Indx As Long
nm As String
Phone As String
Fax As String
Contact As String
GST As String
Email As String
InitDate As String
PostCode As String
End Type

Sub newcontact()
Dim CustomerInfo As CInfo
Dim c As Range, r As Range
Dim msg As String
Dim ws As Worksheet

Set ws = Sheets("Contact List")
Set r = ws.Range(ws.Cells(2, 2), ws.Cells(Rows.Count, 2).End(xlUp))
With CustomerInfo
.Indx = Val(Range("B134")) + 1
.nm = Range("F105")
.Fax = Range("F106")
.Contact = Range("F108")
.GST = Range("F109")
.Phone = Range("C106")
.Email = Range("C107")
.InitDate = Range("C108")
.PostCode = Range("C109")
If Not r.Find(.nm) Is Nothing Then
msg = "A client entry for " & .nm & " already exists. Cannot add
contact. "
MsgBox msg, vbCritical, "Add New Contact"
Else
Set c = r(r.Count + 1)
Application.ScreenUpdating = False
c(1, 0) = .Indx
c(1, 1) = .nm
c(1, 2) = .Phone
c(1, 3) = .Fax
c(1, 4) = .Email
c(1, 5) = .InitDate
c(1, 6) = .Contact
c(1, 7) = .PostCode
c(1, 8) = .GST
Application.ScreenUpdating = True
End If
End With
End Sub

Regards,
Greg
 
Back
Top