Comparing Lists for new values - Dictionary or Array?

[Davavo]

Hi folks.
I have some working code here but it is very slow. Could anyone suggest a faster alternative?
I did try using the dictionary but eventually gave up. It was the passing of the dictionary to and from the sub while also passing the sheet name that was causing the problems.
I think perhaps using an array would be faster and easier. But i am not sure.

The workbook is to record emails.
A new sheet will be added by the user, that will have a list of email addresses.
The code looks through that sheet and compares each value to an existing archive of email addresses. If no match is found, the email is added to the bottom of the archive list.
Any help would be greatly appreciated. Thanks.

'Reads through a list of values in Column A of a worksheet (worksheet name is variable 'NamecatchString' passed from main sub)
'and compares each value to an archive list, adding any new values to the archive

Sub CompareAndWrite(NamecatchString As String)
    Dim Aws As Worksheet                                'The Archive Sheet
    Dim Tws As Worksheet                                'The Target Sheet containing the new list to be checked
    Set Aws = sht_Archive
    Set Tws = ThisWorkbook.Worksheets(NamecatchString)  'There may be several new sheets with lists
   
    Dim ALastRow As Long                                'The last row of the archive
    Dim TLastRow As Long                                'The last row of the Target Sheet
    ALastRow = Aws.Cells(Rows.Count, 1).End(xlUp).row
    TLastRow = Tws.Cells(Rows.Count, 1).End(xlUp).row
   
    Dim Trg As Range
    Set Trg = Tws.Range("A2:A" & TLastRow)              'Declare the Range to be searched

    Dim Arg As Range                                    'Declare the Archive Range
    Dim FoundRg As Range                                'A variable that is defined by finding a match (not sure why it has to be a range rather than a string)
    Dim Cell As Range
   
    For Each Cell In Trg
   
        Set Arg = Aws.Range("A2:A" & ALastRow)
        Set FoundRg = Arg.Find(Cell.Value)
       
        If FoundRg Is Nothing Then                      'If no match is found, add the value in the search to the archive
           
            ALastRow = ALastRow + 1                     'Add one row to last row of the archive
            Aws.Cells(ALastRow, 1).Value = Cell.Value   'Add the search value to the archive
               
                                                                              'Debug.Print "Added " & Cell.Value & " to the archive"
        End If
    Next Cell
   
End Sub

 

[Georgiboy]

What version of Excel are you using and what version would it need to work with?

 

[Davavo]

I am using Excel 2016. It would need to work with 2013

 

[Georgiboy]

Perhaps the below will be faster?

Sub CompareAndWrite()
    Dim Aws As Worksheet
    Dim Tws As Worksheet
    Dim ALastRow As Long
    Dim TLastRow As Long
    Dim aVar As Variant
    Dim cuVar As Variant
    Dim oVar() As Variant
    Dim x As Long, y As Long
   
    Set Aws = Sheet1
    Set Tws = ThisWorkbook.Worksheets("Sheet2")
   
    ALastRow = Aws.Cells(Rows.Count, 1).End(xlUp).Row
    TLastRow = Tws.Cells(Rows.Count, 1).End(xlUp).Row
   
    aVar = Aws.Range("A2:A" & ALastRow).Value
    cuVar = Tws.Range("A2:A" & TLastRow).Value
   
    For x = 1 To UBound(aVar)
        If IsError(Application.Match(aVar(x, 1), cuVar, 0)) Then
            ReDim Preserve oVar(y): oVar(y) = aVar(x, 1): y = y + 1
        End If
    Next x
   
    If y > 0 Then
        Tws.Range("A" & TLastRow + 1).Resize(UBound(oVar) + 1) = Application.Transpose(oVar)
    End If
End Sub

I have changed a few bits like sheet names etc. so I could test what was going on, you will need to match the details back up to your real world workbook.

 

[Davavo]

Thanks but that doesn't seem to work.
It takes the value from A1 in the Archive sheet and writes it to sheets it shouldn't write to.
Perhaps i should have included the main loop:

'Read through the sheets, check if the sheet name matches the list. Dont do anything with the listed sheets
'For each sheet where the Sheetname <> Codename run the subs

Sub MainLoop()

Dim ws As Worksheet
Dim Aws As Worksheet
Set Aws = sht_Archive

    For Each ws In Worksheets
        Select Case ws.Name
            Case "sht_VAR", "sht_Audit", "sht_Archive", "sht_Notes", "sht_INFO" 'If it's one of these sheets, do nothing"
            Case Else
            
                If ws.CodeName <> ws.Name Then
                    
                    'Catch the new sheet name
                    Dim NameCatchString As String
                    NameCatchString = ws.Name
                    
                    'Add new emails to the Archive
                    Call CompareAndWrite(NameCatchString)
                    
                    'Add the sheet name to the archive header column
                    Call WriteNewSheetNameToArchive(NameCatchString)
            
                    'index match column B of the worksheet to the new column of the archive
                    Call IndexMatch(NameCatchString)
        
                    'Change the Codename to the sheetname
                    Call ChangeCodeName(NameCatchString)
        
                End If
        End Select
    Next ws
End Sub

 

[Davavo]

@Georgiboy Thanks again for your imput.
The writing to sheets it shouldnt was a problem with my own code.
It still doesnt work though.

 

[Georgiboy]

Strange, A1 isn't in the scope of the code I created. Both ranges start at row 2.

Perhaps seeing it working in the file i was working in might help?

CompareAndWrite.xlsm

You will need to put some bits back as they were for example i changed the first row of code:

Sub CompareAndWrite(NamecatchString As String)

I also changed the sheet names in the code to match the workbook i was working on.

 

[Georgiboy]

My code would become:

Sub CompareAndWrite(NamecatchString As String)
    Dim Aws As Worksheet
    Dim Tws As Worksheet
    Dim ALastRow As Long
    Dim TLastRow As Long
    Dim aVar As Variant
    Dim cuVar As Variant
    Dim oVar() As Variant
    Dim x As Long, y As Long
   
    Set Aws = sht_Archive
    Set Tws = ThisWorkbook.Worksheets(NamecatchString)
   
    ALastRow = Aws.Cells(Rows.Count, 1).End(xlUp).Row
    TLastRow = Tws.Cells(Rows.Count, 1).End(xlUp).Row
   
    aVar = Aws.Range("A2:A" & ALastRow).Value
    cuVar = Tws.Range("A2:A" & TLastRow).Value
   
    For x = 1 To UBound(aVar)
        If IsError(Application.Match(aVar(x, 1), cuVar, 0)) Then
            ReDim Preserve oVar(y): oVar(y) = aVar(x, 1): y = y + 1
        End If
    Next x
   
    If y > 0 Then
        Tws.Range("A" & TLastRow + 1).Resize(UBound(oVar) + 1) = Application.Transpose(oVar)
    End If
End Sub

If it is writing to the wrong sheets then I would first look at the MainLoop sub and make sure it is passing the correct sheet name etc...

 

[Davavo]

Yes, as i said, that writing to the wrong sheets was my own fault.
After fixing my own code i re-ran your sub.
It doesn't do anything with the columns. It doesnt output any values to the archive.
The other subs run and the code doesnt break. It just doesnt do anything.
This new code does the same as the last code.

 

[Georgiboy]

Did you look at the attachment?

It takes what is in sheet2 and then looks at what is in sheet1 and adds anything from sheet1 that is not in sheet2 already. Thinking about it, that may be the wrong way round???

Other way around below, anything in NamecatchString that is not in sht_Archive will be added to sht_Archive:

Sub CompareAndWrite(NamecatchString As String)
    Dim Aws As Worksheet
    Dim Tws As Worksheet
    Dim ALastRow As Long
    Dim TLastRow As Long
    Dim aVar As Variant
    Dim cuVar As Variant
    Dim oVar() As Variant
    Dim x As Long, y As Long
   
    Set Aws = sht_Archive
    Set Tws = ThisWorkbook.Worksheets(NamecatchString)
   
    ALastRow = Aws.Cells(Rows.Count, 1).End(xlUp).Row
    TLastRow = Tws.Cells(Rows.Count, 1).End(xlUp).Row
   
    aVar = Aws.Range("A2:A" & ALastRow).Value
    cuVar = Tws.Range("A2:A" & TLastRow).Value
   
    For x = 1 To UBound(cuVar)
        If IsError(Application.Match(cuVar(x, 1), aVar, 0)) Then
            ReDim Preserve oVar(y): oVar(y) = cuVar(x, 1): y = y + 1
        End If
    Next x
   
    If y > 0 Then
        Aws.Range("A" & ALastRow + 1).Resize(UBound(oVar) + 1) = Application.Transpose(oVar)
    End If
End Sub