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

 

[Michael M]

****, I missed the Sets for these at the beginning

With Column("L:L") 'find last row and apply to range so it doesn't do entire column
 For Each cell In Percent 'change to cell In range("L2:L" & lastrow)

So go back to the Sets

 

[Biz]

Geez Biz, I have trouble with one.......Australian !!!

I'm Aussie too. Working hard for Australia Day!
Biz

 

[Michael M]

Hah....what..... watching the cricket, having a barbie, and a few coldies !!!..

 

[Biz]

Thanks Michael ,



Here is what I have. Check to see if Michael's suggestions will work for you.


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
Dim TotalRows As Long: TotalRows = ActiveSheet.UsedRange.Rows.Count
Dim Claims As Range: Set Claims = Range("B2:B" & TotalRows)
Dim Age As Range: 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)

'''Dim Claim As String '''Possible not needed

Dim ClaimRef As String

If desPathName = False Then
MsgBox "Stopping because you did not select a file. Reselect a destination file through the menu"
GoTo CleanUp:
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") '''''make changes if possible, see post from Michael
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Range("M1").Value2 = "Non-Pensioner"
Range("N1").Value2 = "Pensioner"
'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
Select Case UCase(cell.Value) '''Converts cell.value to UPPERCASE
Case "MALE", "FEMALE"
'''do nothing
Case "MR", "CAPT", "MR.", "REV", "REVEREND"
cell.Offset(0, 1).Value2 = "Male"
Case " MRS", "MISS", "MRS", "MRS.", "MS", "MISS.", " MISS", " MS"
cell.Offset(0, 1).Value2 = "Female"
End Select
Next cell
'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
Select Case cell.Value
Case 60 To 64 And cell.Value = bvnullstring
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
Range(Cells(cell.Row, 2), (Cells(cell.Row, 12))).Interior.ColorIndex = 2 '''
Case 60 To 64 And UCase(cell.Offset(0, -1).Value) = "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
'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
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).Activate
'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
'GoTo CleanUp:
Else
MsgBox "Stopping because file is not in required format"
'GoTo CleanUp:
End If

CleanUp:
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

Hi Jeff,

Nice coding technique plus comments making it easier to follow.

Another minor detail I picked up is to release set statements from memory

'Release memory
Set [FONT=Courier New]Claims[/FONT] = Nothing

This day age we have fast computers but sometimes it speed difference is not much. There are lots of set statement and release them from memory may help.

Another minor point which I have changed in bold green to utilise your previous set statement.

With ActiveSheet.Sort
.SortFields.Clear
'.SortFields.Add Key:=Range("D2:D" & TotalRows),
.SortFields.Add Key:=Range(Role)
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange Range("B1:L" & TotalRows)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Biz