Solved: Need to remove duplicates based on date in an input box

[JohnnyBravo]

Working with MS Office 2003

I’ve got a favor to ask one of you fine experts and it would mean a lot if you could help me with the following.

I’ve got a long list of people in an Excel Sheet that we use in order to create name badges for a monthly event. The first row contains headers, such as first name, last name, home address etc.
What we’re trying to do is remove duplicate entries before we start the merge process. As soon the workbook is opened, I apply autofilter and choose the event date (located in column U) because we only want to create name badges for the upcoming event.

Column U contains data in the following format:
Tue. Jan 6
Wed. Feb 4
Wed. Mar 11
Thur. Apr 2
Wed. May 13
Wed. June 10
Thur. July 9
Thur. Aug 6

Step #1: Present the user with an input box:
“Please enter the date of the event”
“For Ex: Sept 10”

Step #2: Apply filter based on date entered.

Step #3: Go through the filtered list and remove duplicate names.

I’ve tried using Brett DJ’s “Duplicate Master” add-in utility here but it is of no use. The problem is that some people have signed up using more than 1 e-mail address. So for example:
Col B…………....… Col C……......Col D………..Col K……….Col U
<first name> <last name> <e-mail addy> <address> <event date>
Jane Smith something1@domain.com 123 Main St. Thur. Aug 6
jane smith something2@domain.com 123 main street Thur. Aug 6
Jane Smith something3@domain.com 555 Purple street Thur. Aug 6

How do you tell VBA to remove duplicates only if the name and street matches? In the example above, I want to keep the last two and delete the first Jane.

Step #4: Go through the filtered list and capitalize first letters. With the example above, change “jane smith” to Jane Smith”

Step #5: Afterwards, most of the columns can be deleted. Only columns B,C, & O are necessary.

Step #6: Copy the filtered list to a new workbook and call it “xxx Registrants”. New workbook can be saved in My Docs folder.
xxx = whatever date is entered by the user in the input box.

Step #7: Open MS Word and open a document located in My Documents folder called:
“Name Badges Merge Form.doc”

Is this doable?

[mdmackillop]

Hi Johnny,
A sample file would assist giving a working answer, possibly using Advanced Filter.
A simpler solution might be to concatenate data to a helper column, and get unique values from that e.g. = Upper(A1) & Upper(C1)

[JohnnyBravo]

Ok, I've paired down the Excel file because there are over 1,000 registrants in the original file. When we download the information from the server, it spits out a list of all registrants past and future - and unfortunately there is no way to exclude duplicates.

I've already tried using the Advanced Filter option in Excel (Unique records only) and it does not work for some reason. I think the reason is that it looks for an exact match and sometimes users will sign up using 2 different e-mail addresses. So one row will have Jane doe addy1@domain.com and a duplicate row might contain,
Jane doe addy2@domain.com (add2@domain.com).

There are other differentiating factors. You'll see what I mean when you view the sample worksheet.

[mdmackillop]

Advanced Filter on the Helper column
=UPPER(LEFT(B3,1)) & UPPER(C3) & UPPER(K3)

Is EMPID not unique for each?

[JohnnyBravo]

Advanced Filter on the Helper column
=UPPER(LEFT(B3,1)) & UPPER(C3) & UPPER(K3)

Is EMPID not unique for each?

I don't follow. Are you saying I should create a helper column and enter that formula?

And I don't understand the importance of the EMPID column - how can I use it to filter by date and remove the duplicates?

[JohnnyBravo]

Ok on second thought forget everything. Maybe I've asked for too much in which I can completely understand. I just need to know how to filter properly.

How do I filter so that it ignores the day of the week and just filters by July 9? Again, goiing with the example I gave above, if the information is in this format: "Thur. July 9"

How do you automatically filter by July 9 (month & date) entered by a user in a VBA input box?

[GTO]

Greetings,

Just a question: In Column U where the dates are, if you select one of these cells and look up in the formula bar, does a date appear (like 07/09/2009 or or the same text as is in the cell?

The reason I ask is that if just text, then we'd maybe have issues if the data is ever entered inconsistently. IE - if a string, Thur <> Thu etc.

Anyways, quite possibly Malcom or someone will know better, but I don't see a way to use wildcards or such with a filter. If the user cannot be expected to type the string in completely (including the day name) would a helper column or a userform populated with the listed "dates" be worth considering?

Mark

[GTO]

Greetings,

After pilfering Malcom's idea of filtering a concatenated string, I wrote more than intended. Basically was having a @*(#! of a time remembering how to filter at all, or how to use it when done. Brain-dead I guess.

Anyways, see if this is on the right path.

The critical code is:

Userform Code:

Private Sub cmdOK_Click()
Dim rngDates As Range
Dim rngTable As Range
Dim rCell As Range
Dim wksTemp As Worksheet
Dim i As Long

Application.ScreenUpdating = False

Set rngDates = ThisWorkbook.Worksheets(SHNAME).Range("U:U")
rngDates.AutoFilter Field:=1, Criteria1:=cboDateStrings.Value

On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Temp").Delete
Application.DisplayAlerts = True
On Error GoTo 0

With ThisWorkbook
.Worksheets.Add After:=.Worksheets(.Worksheets(SHNAME).Index)
End With
Set wksTemp = ActiveSheet
wksTemp.Name = "Temp"

With wksJS
Set rngStringDates = .Range("U1:U" & .Cells(Rows.Count, "U").End(xlUp).Row)
rngStringDates.Offset(, -20).Resize(, 21).SpecialCells(xlCellTypeVisible).Copy wksTemp.Range("A1")
.Range("U:U").AutoFilter
End With

With wksTemp
.Range("V1").Value = "COMB"
Set rngTable = .Range("V2:V" & .Cells(Rows.Count, "U").End(xlUp).Row)
rngTable.Formula = "=UPPER(B2)&UPPER(C2)&UPPER(K2)"
rngTable.Value = rngTable.Value

'// Probably a better way, but I was getting stymied... //
For i = rngTable.Rows.Count + 1 To 2 Step -1
If Evaluate("=COUNTIF(" & rngTable.Address & "," & .Cells(i, "V").Address & ")") > 1 Then
.Cells(i, "V").EntireRow.Delete xlUp
End If
Next

.Range("P:V").EntireColumn.Delete xlShiftToLeft
.Range("D:N").EntireColumn.Delete xlShiftToLeft
.Range("A:A").EntireColumn.Delete xlShiftToLeft
.Range("A1:C1").Font.Bold = True

For Each rCell In .Range("A1:B" & .Cells(Rows.Count, "B").End(xlUp).Row)
rCell.Value = StrConv(rCell.Value, vbProperCase)
Next

With .Range("A1").End(xlDown).Offset(1)
.Value = cboDateStrings.Value
.Font.Bold = True
End With

.Range("A:C").EntireColumn.AutoFit
End With
Application.ScreenUpdating = True

Unload Me
End Sub


In a Standard Module:

Option Explicit

Public wksJS As Worksheet
Public rngStringDates As Range
Public Const SHNAME As String = "Jobseekers"

Sub showform()
UserForm1.Show
End Sub

Function GetDateStrings() As Variant()
Dim i As Long
Dim aryDates
Dim COLL As New Collection

Set wksJS = ThisWorkbook.Worksheets(SHNAME)

With wksJS
.Range(.Cells(1, 1), .Cells(Rows.Count, 1)).EntireRow.Hidden = False
Set rngStringDates = .Range("U2:U" & .Cells(Rows.Count, "U").End(xlUp).Row)
End With

aryDates = rngStringDates.Value

On Error Resume Next
For i = LBound(aryDates, 1) To UBound(aryDates, 1)
COLL.Add aryDates(i, 1), CStr(aryDates(i, 1))
Next
On Error GoTo 0

ReDim aryDates(1 To COLL.Count)

For i = 1 To COLL.Count
aryDates(i) = COLL(i)
Next

GetDateStrings = aryDates
End Function


Hope that helps,

Mark

[Krishna Kumar]

Here is my take on this

You need a userform with a combobox

Public ws As Worksheet

Private Sub CommandButton1_Click()
Dim d, i As Long, q(), n As Long, Hdr, nWB As Workbook
Dim dic As Object, s As String, MyFolder As String, fn As String

Set dic = CreateObject("scripting.dictionary")
dic.comparemode = 1
Hdr = Array("Fname", "Lname", "JT1")
d = ws.Range("a2:u" & ws.Range("a" & Rows.Count).End(xlUp).Row)
ReDim q(1 To UBound(d, 1), 1 To 3)
If Len(Me.ComboBox1) Then
For i = 1 To UBound(d, 1)
If d(i, 21) = Me.ComboBox1 Then
s = d(i, 2) & "|" & d(i, 3) & "|" & d(i, 11)
If Not dic.exists(s) Then
n = n + 1
q(n, 1) = StrConv(d(i, 2), vbProperCase)
q(n, 2) = StrConv(d(i, 3), vbProperCase)
q(n, 3) = StrConv(d(i, 15), vbProperCase)
dic.Add s, n
End If
End If
Next
If n > 0 Then
'With ws.Range("a1")
' .Resize(UBound(d, 1) + 1, 21).ClearContents
' .Resize(, 3).Value = Hdr
' .Offset(1).Resize(n, 3).Value = q
'End With
Set nWB = Workbooks.Add
With nWB.Sheets(1)
.Range("a1").Resize(, 3).Value = Hdr
.Range("a2").Resize(n, 3).Value = q
End With
fn = Trim(Mid$(Me.ComboBox1, InStr(1, Me.ComboBox1, ".") + 1))
nWB.SaveAs Filename:=fn & " Registrants"
MsgBox "New workbook: '" & nWB.Name & " has been saved in" & vbNewLine & _
Replace(nWB.FullName, nWB.Name, "")
End If
End If
End Sub

Private Sub UserForm_Initialize()
Dim k, i As Long
Set ws = Sheets("Jobseekers")
k = ws.Range("u1:u" & ws.Range("u" & Rows.Count).End(xlUp).Row)

If IsArray(k) Then
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 2 To UBound(k, 1)
If Not IsEmpty(k(i, 1)) Then
If Not .exists(k(i, 1)) Then
.Add k(i, 1), Nothing
End If
End If
Next
If .Count > 0 Then
If .Count = 1 Then
Me.ComboBox1.AddItem k(i - 1, 1)
Else: Me.ComboBox1.List = Application.Transpose(.keys)
End If
End If
End With
End If
End Sub

HTH

[JohnnyBravo]

Mark,

Yes that is pretty much on target. Instead of inserting a new worksheet, how would you create a new workbook called "xxxx registrants"?
xxxx = whatever date is chosen by the user in the drop down menu box.

By the way, a huge thanks for doing this. I can't thank you enough for taking the time & energy to write this routine.

Krishna,

I would like to try out your routine. How do you run it? I copied & pasted the code into my original excel file, but when I press Alt F8, I do not see any macros listed.

[JohnnyBravo]

Nevermind, accidental duplicate post.

[rbrhodes]

And here's another...

- Two file items you'll want to change, both commented at the top of the code.

-Didn't know what you wanted to do with the merge doc, but the code's in the sub anyways. Right now it simply opens Word with the file then closes Word.

-Not all duplicates will be killed, for example "123 Oak St." doesn't match "123 Oak Street", but the code will get most based on a comparison of Lastname and Street address. I went way farther than I planned to so this will have to do...

[JohnnyBravo]

- Two file items you'll want to change, both commented at the top of the code.

Ok done. In the line where you've got:
dName = "c:\Users\dr\Documents\Name Badges Merge Form.doc"

Could it be changed to the following for an WinXP user?
dName = "%userprofile%\My Documents\Name Badges Merge Form.doc"



And here's another...
-Didn't know what you wanted to do with the merge doc, but the code's in the sub anyways. Right now it simply opens Word with the file then closes Word.

That's fine - i can always just record my own macro for the merge. EZY enuf. to do :)



-Not all duplicates will be killed, for example "123 Oak St." doesn't match "123 Oak Street", but the code will get most based on a comparison of Lastname and Street address. I went way farther than I planned to so this will have to do...

WOW! Talk about some awesome coding - Thank you very very much.

In fact, all you guys, I can't thank you guys enough for all this coding. I've just picked up my first Excel VBA book and seeing all your coding makes me a bit overwhelmed. Just out of curiosity, how long did it take you write that code? I just see all those lines and think, man it's gonna take me forever to get to the level where you guys are now.

[Krishna Kumar]

Krishna,

I would like to try out your routine. How do you run it? I copied & pasted the code into my original excel file, but when I press Alt F8, I do not see any macros listed.
I said


Here is my take on this

You need a userform with a combobox
Anyway find the attached.

HTH

[GTO]

Greetings,

Replace the current cmdOK_Click code with the below. The function shown below it (MyDocs_Exists) also gets pasted into the userform's module.

In short, as long as there's no problem with the path to My Documents, the new wb will be saved there - else - it will save the new wb to the same folder that the workbook w/the code in it resides.

In the Userform's Module:

Private Sub cmdOK_Click()
Dim _
wbNew As Workbook, _
rngDates As Range, _
rngTable As Range, _
rCell As Range, _
wksTemp As Worksheet, _
i As Long, _
strPath2MyDocs As String

Application.ScreenUpdating = False

Set rngDates = ThisWorkbook.Worksheets(SHNAME).Range("U:U")
rngDates.AutoFilter Field:=1, Criteria1:=cboDateStrings.Value

On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Temp").Delete
Application.DisplayAlerts = True
On Error GoTo 0

With ThisWorkbook
.Worksheets.Add After:=.Worksheets(.Worksheets(SHNAME).Index)
End With
Set wksTemp = ActiveSheet
wksTemp.Name = "Temp"

With wksJS
Set rngStringDates = .Range("U1:U" & .Cells(Rows.Count, "U").End(xlUp).Row)
rngStringDates.Offset(, -20).Resize(, 21).SpecialCells(xlCellTypeVisible).Copy _
wksTemp.Range("A1")

.Range("U:U").AutoFilter
End With

With wksTemp
.Range("V1").Value = "COMB"
Set rngTable = .Range("V2:V" & .Cells(Rows.Count, "U").End(xlUp).Row)
rngTable.Formula = "=UPPER(B2)&UPPER(C2)&UPPER(K2)"
rngTable.Value = rngTable.Value

'// Probably a better way, but I was getting stymied... //
For i = rngTable.Rows.Count + 1 To 2 Step -1
If Evaluate( _
"=COUNTIF(" & rngTable.Address & "," & .Cells(i, "V").Address & ")" _
) > 1 Then

.Cells(i, "V").EntireRow.Delete xlUp
End If
Next

.Range("P:V").EntireColumn.Delete xlShiftToLeft
.Range("D:N").EntireColumn.Delete xlShiftToLeft
.Range("A:A").EntireColumn.Delete xlShiftToLeft
.Range("A1:C1").Font.Bold = True

For Each rCell In .Range("A1:B" & .Cells(Rows.Count, "B").End(xlUp).Row)
rCell.Value = StrConv(rCell.Value, vbProperCase)
Next
'// Optional... //
' With .Range("A1").End(xlDown).Offset(1)
' .Value = cboDateStrings.Value
' .Font.Bold = True
' End With
'// Or maybe //
.Name = cboDateStrings.Value

.Range("A:C").EntireColumn.AutoFit

Me.Hide
DoEvents

'// Set a reference to a newly created, one-sheet, wb. //
Set wbNew = Workbooks.Add(xlWBATWorksheet)
'// Move our temp (now renamed to event date) sheet to the new wb and kill //
'// the one blank sheet. //
.Move After:=wbNew.Sheets(1)
Application.DisplayAlerts = False
wbNew.Sheets(1).Delete
Application.DisplayAlerts = True

'// And now - - - proof that I not in a coma and do occasionally grasp stuff!//
'// Levity aside, I just learned this from XLD. Thanks :-) //
'// I've never had a problem with Environ("username") and/or the path to //
'// my documents, but a quick check wouldn't hurt. //
strPath2MyDocs = vbNullString
If Not MyDocs_Exists(strPath2MyDocs) Then
MsgBox "I was unable to find the My Documents folder." & vbCrLf & _
"The new file will be saved in the same folder" & vbCrLf & _
"that this workbook is in.", vbInformation, vbNullString
End If

'// Optional - force save, overwriting any previous wb. If you want to //
'// give the user a choice, you'll need to tack in some err handling //
Application.DisplayAlerts = False
wbNew.SaveAs Filename:=strPath2MyDocs & cboDateStrings.Value & Chr(32) & _
"registrants.xls"
Application.DisplayAlerts = True
wbNew.Close

End With
Application.ScreenUpdating = True

Unload Me

End Sub

Function MyDocs_Exists(strPath As String) As Boolean
Dim FSO As Object '<---FileSystemObject
Dim FOL As Object '<---Folder

Set FSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set FOL = FSO.GetFolder("C:\Documents and Settings\" & _
Environ("UserName") & "\My Documents")
On Error GoTo 0

If Not FOL Is Nothing Then
strPath = FOL.Path & Application.PathSeparator
MyDocs_Exists = True
Else
strPath = ThisWorkbook.Path & Application.PathSeparator
MyDocs_Exists = False
End If
End Function


BTW, in regards to one of your questions, look at Environ("username") as shown above in regards to making it "adjustable" to who's logged on.

Hope this helps,

Mark

[JohnnyBravo]

Mark,

I replaced your original Private Sub cmdOK_Click() routine w/ the revised one you provided. There seems to be a problem. I get a blank drop down menu box. See screenshot attached.
http://i5.photobucket.com/albums/y182/tushman/Blankdropdownmenubox.jpg

Krisha Kumar,

Your vba routine seems to be the most effective out of the 3. It is able to remove the most duplicates possible. I wish I could understand 1/2 of it. Could you please insert some comments into your line so I can understand it? I wish to make a tiny adjustment.

[rbrhodes]

Hi,

This snippet will get you the logged on User name:


Use it as :

UserProfile = fOSUserName

Then this becomes:

Could it be changed to the following for an WinXP user?

dName = UserProfile &"\My Documents\Name Badges Merge Form.doc"




Option Explicit
'******************** Code Start **************************
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Function fOSUserName() As String
'Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If (lngX > 0) Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = vbNullString
End If
End Function
'******************** Code End **************************

[GTO]

Mark,

I replaced your original Private Sub cmdOK_Click() routine w/ the revised one you provided. There seems to be a problem. I get a blank drop down menu box. See screenshot attached.

Hey Johnny,

Given that the buttons don't show captions, I would suspect you erased the userform's initialize event code. Sorry if I was not clear; I only intended that command button's code be updated and the function be added. The form's initialize code is still needed. Attached is the form's code in it's entirety as of last update.

@rbrhodes:

Hi Dusty, a friendly Howdy from Arizona,

Say, for my own learning, have you found the enviromental variable "username" to be less reliable? As Environ... has always worked in my area, I've never tried the API method, or more accurately, I should say I've tried but don't commonly use.

Mark

[Krishna Kumar]

Krisha Kumar,

Your vba routine seems to be the most effective out of the 3. It is able to remove the most duplicates possible. I wish I could understand 1/2 of it. Could you please insert some comments into your line so I can understand it? I wish to make a tiny adjustment.
Thanks !. Will do later this evening (GMT + 5.50)

Edit: OK. here you go..

I'm not good in explain the things. Hope this would help you to understand the code

Public ws As Worksheet
Private Sub CommandButton1_Click()
Dim d, i As Long, q(), n As Long, Hdr, nWB As Workbook
Dim dic As Object, s As String, MyFolder As String, fn As String

Set dic = CreateObject("scripting.dictionary")
dic.comparemode = 1
Hdr = Array("Fname", "Lname", "JT1")
'stores values in a variant array
d = ws.Range("a2:u" & ws.Range("a" & Rows.Count).End(xlUp).Row)
ReDim q(1 To UBound(d, 1), 1 To 3)
If Len(Me.ComboBox1) Then 'if an item selected in combobox, we proceed
For i = 1 To UBound(d, 1)
If d(i, 21) = Me.ComboBox1 Then 'checks date equal to combobox's date
'if so, creates a concatenated string for checking dups. Col B,C and Col K
s = d(i, 2) & "|" & d(i, 3) & "|" & d(i, 11)
If Not dic.exists(s) Then 'stores only unique in an array 'q'
n = n + 1
q(n, 1) = StrConv(d(i, 2), vbProperCase) 'converts to proper case
q(n, 2) = StrConv(d(i, 3), vbProperCase)
q(n, 3) = StrConv(d(i, 15), vbProperCase)
dic.Add s, n
End If
End If
Next
If n > 0 Then 'if we have any data to output
Set nWB = Workbooks.Add 'adds a new workbook
With nWB.Sheets(1)
.Range("a1").Resize(, 3).Value = Hdr 'header
.Range("a2").Resize(n, 3).Value = q 'outputs unique value
End With
fn = Trim(Mid$(Me.ComboBox1, InStr(1, Me.ComboBox1, ".") + 1)) 'extracts month and date
nWB.SaveAs Filename:=fn & " Registrants" 'creates filename and save the file
MsgBox "New workbook: '" & nWB.Name & " has been saved in" & vbNewLine & _
Replace(nWB.FullName, nWB.Name, "")
End If
End If
End Sub

Private Sub UserForm_Initialize()
Dim k, i As Long
Set ws = Sheets("Jobseekers")
k = ws.Range("u1:u" & ws.Range("u" & Rows.Count).End(xlUp).Row)

If IsArray(k) Then
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 2 To UBound(k, 1)
If Not IsEmpty(k(i, 1)) Then
If Not .exists(k(i, 1)) Then 'adds unique dates from Col U
.Add k(i, 1), Nothing
End If
End If
Next
If .Count > 0 Then
If .Count = 1 Then
Me.ComboBox1.AddItem k(i - 1, 1)
Else: Me.ComboBox1.List = Application.Transpose(.keys)
End If
End If
End With
End If
End Sub

[JohnnyBravo]

You guys are awesome. Thanks for all your efforts and following up on this thread. Can't thank you enough.

[JohnnyBravo]

Edit: OK. here you go..

I'm not good in explain the things. Hope this would help you to understand the code

Thanks for comments, but I'm still a little lost.

I need to keep the column named "Industry" which is column S. I've looked over your code several times and I cannot figure out which lines to modify in order to show that column. I know the Hdr array need to be modified to the following, but what else am I missing??

Hdr = Array("Fname", "Lname", "JT1", "Industry")

Secondly, I want to sort the newly created workbook by last name and then first name. I've tried many different code snippets but I'm getting errors.

And finally, I added a few lines to delete the extra blank sheets, but I'm stumped. It's very odd how it can delete #2, but errors out when deleting sheet #3.

With nWB.Sheets(1)
.Range("a1").Resize(, 4).Value = Hdr
.Range("a2").Resize(n, 4).Value = q
.sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2"), _
Order2:=xlAscending, Header:= xlYes , OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
End With
With nWB.Sheets(2)
.Delete
End With
With nWB.Sheets(3)
.Delete
End With

[Aussiebear]

try changing; Order2 = xldescending

[Krishna Kumar]

Public ws As Worksheet

Private Sub CommandButton1_Click()
Dim d, i As Long, q(), n As Long, Hdr, nWB As Workbook
Dim dic As Object, s As String, MyFolder As String, fn As String

Set dic = CreateObject("scripting.dictionary")
dic.comparemode = 1
Hdr = Array("Fname", "Lname", "JT1", "Industry") 'modified this line
d = ws.Range("a2:u" & ws.Range("a" & Rows.Count).End(xlUp).Row)
ReDim q(1 To UBound(d, 1), 1 To 4) 'modified this line
If Len(Me.ComboBox1) Then
For i = 1 To UBound(d, 1)
If d(i, 21) = Me.ComboBox1 Then
s = d(i, 2) & "|" & d(i, 3) & "|" & d(i, 11)
If Not dic.exists(s) Then
n = n + 1
q(n, 1) = StrConv(d(i, 2), vbProperCase)
q(n, 2) = StrConv(d(i, 3), vbProperCase)
q(n, 3) = StrConv(d(i, 15), vbProperCase)
q(n, 4) = StrConv(d(i, 19), vbProperCase) '<== added here
dic.Add s, n
End If
End If
Next
If n > 0 Then
Set nWB = Workbooks.Add
With nWB.Sheets(1)
.Range("a1").Resize(, 4).Value = Hdr 'modified this line
.Range("a2").Resize(n, 4).Value = q 'modified this line
'additional code for sorting
.Cells(1).Resize(n + 1, 4).Sort Key1:=.Range("B2"), Order1:=xlAscending, Key2:=.Range("A2") _
, Order2:=xlAscending, Header:=xlGuess
.Cells(1).Resize(n + 1, 4).EntireColumn.AutoFit 'autofits the columns
End With
'// code for deleting the unnecessary sheets
Application.DisplayAlerts = 0
'delete sheet
nWB.Sheets(3).Delete
nWB.Sheets(2).Delete
Application.DisplayAlerts = 1
fn = Trim(Mid$(Me.ComboBox1, InStr(1, Me.ComboBox1, ".") + 1))
nWB.SaveAs Filename:=fn & " Registrants"
MsgBox "New workbook: '" & nWB.Name & " has been saved in" & vbNewLine & _
Replace(nWB.FullName, nWB.Name, "")
End If
End If
Unload Me
End Sub

Private Sub UserForm_Initialize()
Dim k, i As Long
Set ws = Sheets("Jobseekers")
k = ws.Range("u1:u" & ws.Range("u" & Rows.Count).End(xlUp).Row)

If IsArray(k) Then
With CreateObject("scripting.dictionary")
.comparemode = 1
For i = 2 To UBound(k, 1)
If Not IsEmpty(k(i, 1)) Then
If Not .exists(k(i, 1)) Then
.Add k(i, 1), Nothing
End If
End If
Next
If .Count > 0 Then
If .Count = 1 Then
Me.ComboBox1.AddItem k(i - 1, 1)
Else: Me.ComboBox1.List = Application.Transpose(.keys)
End If
End If
End With
End If
End Sub

[JohnnyBravo]

Krishna,

Thanks for the modifications. That did it.

Just out curiosity, what is a scripting dictionary? I was trying to compare some differences with your code versus the other ones in this thread, and best I can guess I think it's the primary reason why it's able to detect the dupes better than the others.

Is that some sort of a special function built into VBA?
Set dic = CreateObject("scripting.dictionary")

[Krishna Kumar]

Hi,

This might help you

http://msdn.microsoft.com/en-us/library/x4k5wbx4(VS.85).aspx

[JohnnyBravo]

I wish to thank everyone who contributed to this thread.

GTO and rbrhodes,
although I did not use your code for the final version of my excel worksheet, your efforts have not been for naught. I truly appreciate the effort and time, and seeing the various ways the routine can be designed will help me in understanding VBA better as a newbie.