VBA optimisation with three loops

[abender777]

Hi , I have a macro that looks at an email address list one by one (there are 3865+), and will take each individual email address and compare it to another list of emails (37,314 in this). If it matches one, it will then compare the cell next to it with a column heading on the first sheet, if it matches, it adds a 1 to the cell. It loops through all this, checking 3865 emails x 37,314 (stops if it finds one) x 681 columns.

Any chance someone could suggest some improvements to this? I also have calculations set to manual. I need it done very soon for a client.

CODE

Sub Service()


Dim iRow As Long
Dim iColumn As Long
Dim iServiceRow As Long
Dim sDest As String
Dim email As String
Const iServiceRowMax = 37314
Const iRowMax = 3865
Dim EmailService As String
Const iColumnMax = 12
Application.ScreenUpdating = False
EmailService = "EmailService1"
iRow = 1
iServiceRow = 1


iColumn = 12
sDest = "Final"




Do While iColumn <= iColumnMax
    iColumn = iColumn + 1
        Do While iRow <= iRowMax
        iServiceRow = 1
        iRow = iRow + 1


            Do While iServiceRow <= iServiceRowMax
            iServiceRow = iServiceRow + 1
            email = Sheets(sDest).Cells(iRow, 4).Value
            If email = Sheets(EmailService).Cells(iServiceRow, 1).Value Then
                If Sheets(sDest).Cells(1, iColumn).Value = Sheets(EmailService).Cells(iServiceRow, 2).Value Then
                Sheets(sDest).Cells(iRow, iColumn).Value = 1
                iServiceRow = 37315
                End If
            End If


Loop


Loop
iServiceRow = 1
iRow = 1
Loop






End Sub

 

[JoeMo]

Haven't looked at your code closely, but I suspect you would benefit by using something like this assuming you have set R to the long list of emails you want to search:

Dim n as Variant, R as Range
On Error Resume Next
n= application.match(value from your short list,R,0)
On Error GoTo 0
If n >0 then ' found a match to the email address, next check the companion in R.Cells.offset(0,1) ...