Very Slow For Each If then statement

[The Damned]

Hi this is my first post. I have recently started writing some basic vba code based on bits I have picked up recording macros and searching this formum.

I have a spreadsheet which contains records of customers and their partners (though sharing a claim reference), their gender and their age amongst other fields. The code I have written is designed to achieve the following:

• Look through the age column and if the person is female and over 60, or male and over 65, or between 60-65 and gender not specified mark as being a pensioner. NOTE: only one of a couple (CL or PT) must meet the age criteria
• Once each record has been identified as pensioner or not I need to split the list into two sheets; 1 of pensioners and 1 of non-pensioners.
• Once split I need to remove the duplicate claim references (i.e. where this is a CL and PT with the same reference)

so far my code seems to correctly do what I want for the non-pensioner claims but does not seem to do so for the pensioner ones. Whislt this is not ideal it is not my main concern as I should be able to puzzle out why (though any help would be appreciated).

The main problem is that my code is currently taking about 20 minutes to run which is not really suitable.

Can anyone advise me how I could speed this code up. NOTE: have read some bits on forums about reading writing to arrays rather than line by line but did not really understand how that would translate for me. I have included my code below. Hope this is posted correctly and appologies if not.

Sub latest2()

Dim start_time, end_time
start_time = Now()

'Get current state of various Excel settings

screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
calcState = Application.Calculation
eventsState = Application.EnableEvents
displayPageBreakState = ActiveSheet.DisplayPageBreaks
'turn off some Excel functionality so code runs faster
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

'set and select file to be sorted

Dim desPathName As Variant
desPathName = Application.GetOpenFilename
If desPathName = False Then
MsgBox "Stopping because you did not select a file. Reselect a destination file through the menu"
Exit Sub
Else
Workbooks.Open Filename:=desPathName
End If

'copy's the claim column to the end of the column ranges to be used to mark pensioner and non-pensioner rows accordingly

Range("B:B").Copy Destination:=Range("M:N")
Range("M1").Value2 = "Non-Pensioner"
Range("N1").Value2 = "Pensioner"

Dim Claims As Range
Dim Age As Range
Dim TotalRows As Long
Dim Claim As String
TotalRows = ActiveSheet.UsedRange.Rows.Count
Dim ClaimRef As String
Set Claims = Range("B2:B" & TotalRows)
Set Age = Range("G2:G" & TotalRows)
Dim Role As Range
Set Role = Range("D2:D" & TotalRows)
Dim Sex As Range
Set Sex = Range("F2:F" & TotalRows)
Dim Passported As Range
Set Passported = Range("K2:K" & TotalRows)
Dim Title As Range
Set Title = Range("E2:E" & TotalRows)
Dim Percent As Range
Set Percent = Range("L2:L" & TotalRows)
Dim NonPensioner As Range
Set NonPensioner = Range("M2:M" & TotalRows)
Dim Pensioner As Range
Set Pensioner = Range("N2:N" & TotalRows)

'checks that the data is set out in the columns as expected in order for code to work etc

If Range("B1").Value2 = "Current Claim Number" And _
Range("C1").Value2 = "Tenure Type" And Range("D1").Value2 = "Claim Role" And Range("E1").Value2 = "Title" And Range("G1").Value2 = "Age" _
And Range("F1").Value2 = "Gender" And Range("H1").Value2 = "Gross Liability" And Range("I1").Value2 = _
"Rent Used in Calculation" And Range("J1").Value2 = "Latest Weekly Entitlement" And Range("K1").Value2 = "Income Support Indicator" Then

'turn off autofilter

ActiveSheet.AutoFilterMode = False

'sets column L as a percentage column and calculates percentage for each row

Range("L1").Value2 = "Rebate %"
With Percent
.Style = "Percent"
.Font.Name = "Arial"
.Font.Size = 9
End With
For Each cell In Percent
If cell.Offset(0, -3).Value2 = 0 Then
cell.Value2 = "N/A"
Else
cell.Value2 = cell.Offset(0, -2).Value2 / cell.Offset(0, -3).Value2
End If
Next

' for records where the Gender is not specified populates a the gender field based on Title Criteria

For Each cell In Title
If cell.Offset(0, 1).Value2 = "Male" Or cell.Offset(0, 1).Value2 = "Female" Or cell.Offset(0, 1).Value2 = "MALE" Or cell.Offset(0, 1).Value2 = "FEMALE" Then
Else
If cell.Value2 = " Mr" Or cell.Value2 = "Capt" Or cell.Value2 = "Mr" Or cell.Value2 = "Mr." Or cell.Value2 = "Rev" Or cell.Value2 = "Reverend" Then
cell.Offset(0, 1).Value2 = "Male"
Else
If cell.Value2 = " Mrs" Or cell.Value2 = "Miss" Or cell.Value2 = "Mrs" Or cell.Value2 = "Mrs." Or cell.Value2 = "Ms" Or cell.Value2 = " Ms" Or cell.Value2 = "Ms." _
Or cell.Value2 = "Miss." Or cell.Value2 = " Miss" Then
cell.Offset(0, 1).Value2 = "Female"
Else

End If
End If
End If
Next

'removes all records that are not "CL" (customer) or "PT" (partner)
For Each cell In Role

If cell.Value2 = "CL" Or cell.Value2 = "PT" Then 'Identifies each cell for which the claim role is CL or PT
Else
cell.ClearContents ' If claim role is other than CL or PT, clear the contents of that cell
End If
Next

Role.SpecialCells(xlCellTypeBlanks).EntireRow.delete ' Delete all rows where the Role cell is blank

'looks through age column and marks rows as pensioner or non-pensioner depending on age and gender
'if record is identified as being a pensioner code searches rest of claim column for the same claim reference
'and marks that as pensioner too

For Each cell In Age

If cell.Value2 > 64 Then
ClaimRef = cell.Offset(0, -5).Value2
cell.Offset(0, 5).ClearContents
NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString
Else
If cell.Value2 > 59 And cell.Offset(0, -1).Value2 = "Female" Or cell.Offset(0, -1).Value2 = "FEMALE" Then ' Identifies each cell for which the age is 60 or over
ClaimRef = cell.Offset(0, -5).Value2
cell.Offset(0, 5).ClearContents
NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString
Else
If cell.Value2 > 59 And cell.Value2 < 65 And cell.Offset(0, -1).Value2 = vbullstring Then
ClaimRef = cell.Offset(0, -5).Value2
cell.Offset(0, 5).ClearContents
NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString

With cell.EntireRow.Interior
.Pattern = xlSolid
.PatternColorIndex = 2
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With

End If
End If
End If
Next

'looks through the column used to mark non-pensioner claims and marks the next column as pensioner claims

For Each cell In NonPensioner
If cell.Value2 = vbNullString Then
Else
cell.Offset(0, 1).Value2 = vbNullString
End If
Next

'copies the sheet and names the second sheet as the pensioner sheet

Sheets(1).Name = "Non-Pensioner"
ActiveSheet.Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Pensioner Only"
ActiveSheet.AutoFilterMode = False
Sheets(1).Select

'deletes all records in the non-pensioner sheet that are pensioner claims and deletes the mark-up columns

NonPensioner.SpecialCells(xlCellTypeBlanks).EntireRow.delete

Range("M:N").delete

With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range( _
"D2:D" & TotalRows), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal

.SetRange Range("B1:L" & TotalRows)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

ActiveSheet.Range("$A$1:$L$" & TotalRows).RemoveDuplicates Columns:=2, Header:= _
xlYes


'selects the pensioner sheet and sets relevant ranges

Sheets(2).Select

TotalRows = ActiveSheet.UsedRange.Rows.Count
Set Claims = Range("B2:B" & TotalRows)
Set Age = Range("G2:G" & TotalRows)
Set Role = Range("D2:D" & TotalRows)
Set Sex = Range("F2:F" & TotalRows)
Set Passported = Range("K2:K" & TotalRows)
Set Title = Range("E2:E" & TotalRows)
Set Percent = Range("L2:L" & TotalRows)
Set NonPensioner = Range("M2:M" & TotalRows)
Set Pensioner = Range("N2:N" & TotalRows)

'removes all the non-pensioner records

Pensioner.SpecialCells(xlCellTypeBlanks).EntireRow.delete

Range("M:N").delete

With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range( _
"D2:D" & TotalRows), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal

.SetRange Range("B1:L" & TotalRows)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$L$" & TotalRows).RemoveDuplicates Columns:=2, Header:= _
xlYes

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Else
MsgBox "Stopping because file is not in required format"
Exit Sub
End If

Application.DisplayAlerts = False
'Workbooks("Split Pension Age Claims 2.xlsm").Close
Application.DisplayAlerts = True
Application.DisplayFullScreen = False
Application.DisplayFormulaBar = True
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.DisplayHeadings = True
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHorizontalScrollBar = True
ActiveWindow.DisplayVerticalScrollBar = True
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState 'note this is a sheet-level setting
end_time = Now()
MsgBox (DateDiff("s", start_time, end_time))
End Sub

 

[repairman615]

Hello,

See if this could help:


<font face=Courier New><SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cell <SPAN style="color:#00007F">In</SPAN> Title<br>    <SPAN style="color:#00007F">Select</SPAN> <SPAN style="color:#00007F">Case</SPAN> UCase(cell.Value) <SPAN style="color:#007F00">'''Converts cell.value to UPPERCASE</SPAN><br>        <SPAN style="color:#00007F">Case</SPAN> "MALE", "FEMALE"<br>        <SPAN style="color:#007F00">'''do nothing</SPAN><br>        <SPAN style="color:#00007F">Case</SPAN> "MR", "CAPT", "MR.", "REV", "REVEREND"<br>            cell.Offset(0, 1).Value2 = "Male"<br>        <SPAN style="color:#00007F">Case</SPAN> " MRS", "MISS", "MRS", "MRS.", "MS", "MISS.", " MISS", " MS"<br>            cell.Offset(0, 1).Value2 = "Female"<br>        <br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Select</SPAN><br><SPAN style="color:#00007F">Next</SPAN> cell</FONT>

 

[repairman615]

<font face=Courier New><SPAN style="color:#00007F">With</SPAN> cell.EntireRow.Interior<br>.Pattern = xlSolid<br>.PatternColorIndex = 2<br>.ThemeColor = xlThemeColorAccent5<br>.TintAndShade = 0.799981688894314<br>.PatternTintAndShade = 0<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN></FONT>



Also the entire row doesn't seem like a good idea. Maybe try and specify a range that would cover what you need.

 

[Michael M]

As well as Jeffs comments
I see you have a timer set to measure time taken...have you considered using the timer in smaller segments to find out whre the major delay is ?
I'd also go through and change these to a specific range where possible.

Range("B:B").Copy Destination:=Range("M:N")

to Maybe

Range("B1:B" & totalrow).Copy Destination:=Range("M1:N" & totalrow)

If you're using EXcel 07 / 10 thats a million + rows for each copy and paste !

 

[The Damned]

Thanks for everyone for their help so far. I have amended my code to take all the advice into account. Having set several timers through the code I have now ascertained that each part is taking only a few second to run apart from one section which on the last run (using a slower machine than I used last night) took 28 minutes for that section of code. I have pasted the section of code below which is causing the problem. P.S. there are approx 46,000 rows that I'm looping through.


'below code looks through age column and marks rows as pensioner or non-pensioner depending on age and gender if record is identified as being a pensioner code searches rest of claim column for the same claim reference
and marks that row as pensioner too'

For Each cell in Age

If cell.Value2 > 64 Then
ClaimRef = cell.Offset(0, -5).Value2
cell.Offset(0, 6).ClearContents
NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString

Else

If cell.Value2 > 59 And cell.Offset(0, -1).Value2 = "Female" Or cell.Offset(0, -1).Value2 = "FEMALE" Then      
ClaimRef = cell.Offset(0, -5).Value2
cell.Offset(0, 6).ClearContents
NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString

Else

If cell.Value2 > 59 And cell.Value2 < 65 And cell.Offset(0, -1).Value2 = vbullstring Then
ClaimRef = cell.Offset(0, -5).Value2
cell.Offset(0, 6).ClearContents
NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString

With Range(Cells(cell.Row, 2), (Cells(cell.Row, 12))).Interior
        .Pattern = xlSolid
        .PatternColorIndex = 2
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
 End With
 
End If
End If
End If
Next

Thanks again for the help, it is very much appreciated

 

[The Damned]

Hi Michael, I have amended some of my code to take your advice into account and have posted the outcome of that. Wasn't sure if I needed to reply directly to your coments in order for you to see them though (hence this post). sorry, i'm new to all this!

 

[repairman615]

See if this make a difference in time:

<font face=Courier New><SPAN style="color:#00007F">Select</SPAN> <SPAN style="color:#00007F">Case</SPAN> cell.Value<br>    <SPAN style="color:#00007F">Case</SPAN> 60 <SPAN style="color:#00007F">To</SPAN> 64 And cell.Value = bvnullstring<br>        ClaimRef = cell.Offset(0, -5).Value2<br>                cell.Offset(0, 6).ClearContents<br>                NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString<br>                <SPAN style="color:#00007F">With</SPAN> Range(Cells(cell.Row, 2), (Cells(cell.Row, 12))).Interior<br>                        .Pattern = xlSolid<br>                        .PatternColorIndex = 2<br>                        .ThemeColor = xlThemeColorAccent5<br>                        .TintAndShade = 0.799981688894314<br>                        .PatternTintAndShade = 0<br>                <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>    <SPAN style="color:#00007F">Case</SPAN> 60 <SPAN style="color:#00007F">To</SPAN> 64 And UCase(cell.Offset(0, -1).Value) = "FEMALE"<br>        ClaimRef = cell.Offset(0, -5).Value2<br>            cell.Offset(0, 6).ClearContents<br>            NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString<br>    <SPAN style="color:#00007F">Case</SPAN> <SPAN style="color:#00007F">Is</SPAN> > 64<br>        ClaimRef = cell.Offset(0, -5).Value2<br>        cell.Offset(0, 6).ClearContents<br>        NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Select</SPAN></FONT>

 

[The Damned]

Thanks Jeff, I had to amend the code slightly as shown below, however, the outcome of changing my code that you have provide is a massive improvement on time. The total time for that portion is now down to 381 seconds, with the total time for the code being 526 seconds. If this could be sped up further then that would be great but if not then this is still far better than before. Thanks again. My amendment of your code shown below (it was only a typo in the first couple of lines)

For Each cell In Age

Select Case cell.Value2
    Case 60 To 64 And cell.Offset(0, -1).Value2 = vbNullString
        ClaimRef = cell.Offset(0, -5).Value2
                cell.Offset(0, 6).ClearContents
                NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString
                With Range(Cells(cell.Row, 2), (Cells(cell.Row, 12))).Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = 2
                        .ThemeColor = xlThemeColorAccent5
                        .TintAndShade = 0.799981688894314
                        .PatternTintAndShade = 0
                End With
    Case 60 To 64 And UCase(cell.Offset(0, -1).Value2) = "FEMALE"
        ClaimRef = cell.Offset(0, -5).Value2
            cell.Offset(0, 6).ClearContents
            NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString
    Case Is > 64
        ClaimRef = cell.Offset(0, -5).Value2
        cell.Offset(0, 6).ClearContents
        NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString
End Select
Next

 

[Michael M]

@Jeff
Nice shortcuts !

@TheDamned

Try commenting out this section, as a test

With Range(Cells(cell.Row, 2), (Cells(cell.Row, 12))).Interior
                        .Pattern = xlSolid
                        .PatternColorIndex = 2
                        .ThemeColor = xlThemeColorAccent5
                        .TintAndShade = 0.799981688894314
                        .PatternTintAndShade = 0
                End With

and then change to

Range(Cells(cell.Row, 2), (Cells(cell.Row, 12))).Interior.colorindex = 2

 

[Biz]

Try Speed codes below

'Speeding Up VBA Code
    With Application
        .ScreenUpdating = False 'Prevent screen flickering
        '.Calculation = xlCalculationManual 'Preventing calculation
        .DisplayAlerts = False 'Turn OFF alerts
        .EnableEvents = False 'Prevent All Events
    End With
    
'Your code
 
'Speeding Up VBA Code
    With Application
        .ScreenUpdating = True 'Prevent screen flickering
        '.Calculation = xlAutomatic 'Preventing calculation
        .DisplayAlerts = True 'Turn OFF alerts
        .EnableEvents = True 'Prevent All Events
    End With

Biz