VBA Code

[eab913]

Hi,

I have been working on this problem for a while, and am stuck at a juncture: I have two very large email lists, one with 30,000 emails and one with 100,000 emails. I want to write a vba code that will keep only the email addressed in the list of 30,000 (Sheet1) and also in the list of 100,000 (sheet2).

Is the best way to do this to write an "if/then" statement going line by line and copying the duplicates into a new sheet? I feel like there has to be an easier way, perhaps using the match or v-lookup function. Any help would be greatly appreciated.

Thanks.

 

[JLGWhiz]

Assuming the 30k are in Sheet one Column A and the 100k are in Sheet two Column A, you could use a statement something like:


lastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
x = 2
For Each c In Sheets(1).Range("A2:A" & lastRow)
If WorksheetFunction.CountIf(Sheets(2).Range("A2:A" & Range("A100025").End(xlUp).Row), c.Value) > 0 Then
c.Copy Sheets(1).Range("C" & x)
x = x + 1
End If

The range references here are arbitrary since I have no idea how your worksheets are set up, but the idea is to take the shortest list and check it against the longest list to see if it can find a match, If it does, isolate that address by copying it to a third range somewhere.

 

[GTO]

Hi there,

You might want to try using a couple of Dictionaries. For something like:

Excel 2000
	A	B	C	D
1	LIst 1	List 2		Output
2	Mike@aaa.net	Mike@aaa.com		Mike@aaa.com
3	Mike@aaa.com	Matt@aaa.com		Matt@aaa.com
4	Mark@bbb.com	Lawrence@ccc.net		Lars@aaa.net
5	Matt@aaa.com	Lars@aaa.net		Jeniffer@ddd.com
6	Ben@ccc.net	Jeniffer@ddd.com		Amy@eee.net
7	Larry@ccc.net	Amy@eee.net
8	Lars@aaa.net
9	Humphrey@ccc.com
10	Bill@ccc.net
11	Jeniffer@ddd.com
12	Jeniffer@ddd.com
13	Amy@eee.net
14	Amy@eee.net
15	Amy@ez.com
EMail List

In a Standard Module:

Option Explicit
Sub example()
Dim DIC_Big         As Object ' Dictionary
Dim DIC_Small       As Object ' Dictionary
Dim wks             As Worksheet
Dim rngData         As Range
Dim aryDataBig      As Variant
Dim aryDataSmall    As Variant
Dim aryOutput       As Variant
Dim n               As Long
    
    Set wks = ThisWorkbook.Worksheets("Email List") '<---Change to suit.
    
    With wks
        '// Change what column we are looking (for the bigger list) in to suit.         //
        Set rngData = RangeFound(.Range(.Cells(2, 1), .Cells(.Rows.Count, 1)))
        
        '// Bail if no data.                                                            //
        If rngData Is Nothing Then Exit Sub
        
        '// Plunk the values from the bigger range into an array.                       //
        aryDataBig = .Range(.Cells(2, 1), rngData).Value
        
        '// Should not be "needed" but for clarity                                      //
        Set rngData = Nothing
        '// Change what column we are looking (for the smaller list) in to suit.        //
        Set rngData = RangeFound(.Range(.Cells(2, 2), .Cells(.Rows.Count, 2)))
        
        If rngData Is Nothing Then Exit Sub
        
        aryDataSmall = .Range(.Cells(2, 2), rngData).Value
        
        '// Create and set references to two dictionaries.                              //
        Set DIC_Big = CreateObject("Scripting.Dictionary")
        Set DIC_Small = CreateObject("Scripting.Dictionary")
        
        '// Just loop in the keys to build a list of ubique vals.                       //
        For n = 1 To UBound(aryDataBig, 1)
            DIC_Big.Item(aryDataBig(n, 1)) = Empty
        Next
        
        For n = 1 To UBound(aryDataSmall, 1)
            DIC_Small.Item(aryDataSmall(n, 1)) = Empty
        Next
        
        '// To use late-bound, plunk the keys from the small DIC into an array (we are  //
        '// just re-using aryDataSmall, which will now be 1-D in nature.                //
        aryDataSmall = DIC_Small.Keys
        
        For n = LBound(aryDataSmall, 1) To UBound(aryDataSmall, 1)
            '// In essence, loop thru keys in small dictionary, testing ea to see if it //
            '// exists in big dictionary.  If not, remove from small dictionary         //
            If Not DIC_Big.Exists(aryDataSmall(n)) Then DIC_Small.Remove (aryDataSmall(n))
        Next
        
        '// Again, reuse array, plunking in remaining keys.                             //
        aryDataSmall = DIC_Small.Keys
        
        '// You can probably use Application.TRanspose for this bit.  I'm currently in  //
        '// Excel 2000, and there's something like a 512 cell limit.  Anyways, I just   //
        '// prefer "manually" transposing.                                              //
        ReDim aryOutput(LBound(aryDataSmall, 1) To UBound(aryDataSmall, 1), 1 To 1)
        
        For n = LBound(aryDataSmall, 1) To UBound(aryDataSmall, 1)
            aryOutput(n, 1) = aryDataSmall(n)
        Next
        
        .Range("D2").Resize(UBound(aryOutput, 1) - LBound(aryOutput, 1) + 1).Value = aryOutput
    End With
End Sub
    
Function RangeFound(SearchRange As Range, _
                    Optional ByVal FindWhat As String = "*", _
                    Optional StartingAfter As Range, _
                    Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
                    Optional LookAtWholeOrPart As XlLookAt = xlPart, _
                    Optional SearchRowCol As XlSearchOrder = xlByRows, _
                    Optional SearchUpDn As XlSearchDirection = xlPrevious, _
                    Optional bMatchCase As Boolean = False) As Range
    
    If StartingAfter Is Nothing Then
        Set StartingAfter = SearchRange(1)
    End If
    
    Set RangeFound = SearchRange.Find(What:=FindWhat, _
                                      After:=StartingAfter, _
                                      LookIn:=LookAtTextOrFormula, _
                                      LookAt:=LookAtWholeOrPart, _
                                      SearchOrder:=SearchRowCol, _
                                      SearchDirection:=SearchUpDn, _
                                      MatchCase:=bMatchCase)
End Function

Hope that helps,

Mark

 

[eab913]

Wow, thank you both for your help! This helps so much!!

I'm thinking maybe I can copy and past it all into one list and identify the duplicates, put a binary number in a new column next to the duplicates and then copying and pasting the emails with a value of, say 1, and then remove the duplicates from that list. What do you think of that approach?

 

[mirabeau]

Wow, thank you both for your help! This helps so much!!

I'm thinking maybe I can copy and past it all into one list and identify the duplicates, put a binary number in a new column next to the duplicates and then copying and pasting the emails with a value of, say 1, and then remove the duplicates from that list. What do you think of that approach?

Does your answer suggest that you are somehow not happy with the answers that have been provided?

I think the approach you suggest could be worked through, but seems likely to be pretty slow and inefficient. But, if you want it done that way ...

If it were me tackling the problem of a list starting from Cell A2 on sheet1, another list starting from A2 on sheet2, and recording elements common to both lists on sheet 3, then I'd just run a macro something like this

Sub commonto2lists()
Dim d1 As Object, d2 As Object, e

Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")

For Each e In Sheets("sheet1").Range("A2").CurrentRegion.Value
    d1(e) = 1
Next

For Each e In Sheets("sheet2").Range("A2").CurrentRegion.Value
    If d1(e) = 1 Then d2(e) = 1
Next

If d2.Count > 0 Then _
    Sheets("sheet3").Range("A2").Resize(d2.Count) = _
    Application.Transpose(d2.keys) _
    Else MsgBox "No entries common to the 2 sheets"
End Sub