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]

Hi Biz
the OP already has them in the code.....see Post # 1

 

[repairman615]

Thanks Michael ,



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


<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> latest2()<br><SPAN style="color:#007F00">''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> start_time, end_time<br>start_time = Now()<br><br><SPAN style="color:#007F00">'Get current state of various Excel settings</SPAN><br>screenUpdateState = Application.ScreenUpdating<br>statusBarState = Application.DisplayStatusBar<br>calcState = Application.Calculation<br>eventsState = Application.EnableEvents<br>displayPageBreakState = ActiveSheet.DisplayPageBreaks<br><SPAN style="color:#007F00">'turn off some Excel functionality so code runs faster</SPAN><br>Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>Application.DisplayStatusBar = <SPAN style="color:#00007F">False</SPAN><br>Application.Calculation = xlCalculationManual<br>Application.EnableEvents = <SPAN style="color:#00007F">False</SPAN><br>ActiveSheet.DisplayPageBreaks = <SPAN style="color:#00007F">False</SPAN><br><br><SPAN style="color:#007F00">'set and select file to be sorted</SPAN><br><SPAN style="color:#00007F">Dim</SPAN> desPathName <SPAN style="color:#00007F">As</SPAN> Variant: desPathName = Application.GetOpenFilename<br><SPAN style="color:#00007F">Dim</SPAN> TotalRows <SPAN style="color:#00007F">As</SPAN> Long: TotalRows = ActiveSheet.UsedRange.Rows.Count<br><SPAN style="color:#00007F">Dim</SPAN> Claims <SPAN style="color:#00007F">As</SPAN> Range: <SPAN style="color:#00007F">Set</SPAN> Claims = Range("B2:B" & TotalRows)<br><SPAN style="color:#00007F">Dim</SPAN> Age <SPAN style="color:#00007F">As</SPAN> Range: <SPAN style="color:#00007F">Set</SPAN> Age = Range("G2:G" & TotalRows)<br><SPAN style="color:#00007F">Dim</SPAN> Role <SPAN style="color:#00007F">As</SPAN> Range: <SPAN style="color:#00007F">Set</SPAN> Role = Range("D2:D" & TotalRows)<br><SPAN style="color:#00007F">Dim</SPAN> Sex <SPAN style="color:#00007F">As</SPAN> Range: <SPAN style="color:#00007F">Set</SPAN> Sex = Range("F2:F" & TotalRows)<br><SPAN style="color:#00007F">Dim</SPAN> Passported <SPAN style="color:#00007F">As</SPAN> Range: <SPAN style="color:#00007F">Set</SPAN> Passported = Range("K2:K" & TotalRows)<br><SPAN style="color:#00007F">Dim</SPAN> Title <SPAN style="color:#00007F">As</SPAN> Range: <SPAN style="color:#00007F">Set</SPAN> Title = Range("E2:E" & TotalRows)<br><SPAN style="color:#00007F">Dim</SPAN> Percent <SPAN style="color:#00007F">As</SPAN> Range: <SPAN style="color:#00007F">Set</SPAN> Percent = Range("L2:L" & TotalRows)<br><SPAN style="color:#00007F">Dim</SPAN> NonPensioner <SPAN style="color:#00007F">As</SPAN> Range: <SPAN style="color:#00007F">Set</SPAN> NonPensioner = Range("M2:M" & TotalRows)<br><SPAN style="color:#00007F">Dim</SPAN> Pensioner <SPAN style="color:#00007F">As</SPAN> Range: <SPAN style="color:#00007F">Set</SPAN> Pensioner = Range("N2:N" & TotalRows)<br>    <br><SPAN style="color:#007F00">'''Dim Claim As String  '''Possible not needed</SPAN><br><br><SPAN style="color:#00007F">Dim</SPAN> ClaimRef <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN><br>    <br>    <SPAN style="color:#00007F">If</SPAN> desPathName = <SPAN style="color:#00007F">False</SPAN> <SPAN style="color:#00007F">Then</SPAN><br>        MsgBox "Stopping because you did not select a file. Reselect a destination file through the menu"<br><SPAN style="color:#00007F">GoTo</SPAN> CleanUp:<br>    <SPAN style="color:#00007F">Else</SPAN><br>        Workbooks.Open Filename:=desPathName<br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><SPAN style="color:#007F00">'copy's the claim column to the end of the column ranges to be used to</SPAN><br><SPAN style="color:#007F00">'mark pensioner and non-pensioner rows accordingly</SPAN><br><SPAN style="color:#007F00">''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''</SPAN><br>Range("B:B").Copy Destination:=Range("M:N") <SPAN style="color:#007F00">'''''make changes if possible, see post from Michael</SPAN><br><SPAN style="color:#007F00">'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''</SPAN><br>Range("M1").Value2 = "Non-Pensioner"<br>Range("N1").Value2 = "Pensioner"<br><SPAN style="color:#007F00">'checks that the data is set out in the columns as expected in order for code to work etc</SPAN><br>    <SPAN style="color:#00007F">If</SPAN> Range("B1").Value2 = "Current Claim Number" And _<br>            Range("C1").Value2 = "Tenure Type" And _<br>            Range("D1").Value2 = "Claim Role" And _<br>            Range("E1").Value2 = "Title" And _<br>            Range("G1").Value2 = "Age" And _<br>            Range("F1").Value2 = "Gender" And _<br>            Range("H1").Value2 = "Gross Liability" And _<br>            Range("I1").Value2 = "Rent Used in Calculation" And _<br>            Range("J1").Value2 = "Latest Weekly Entitlement" And _<br>            Range("K1").Value2 = "Income Support <SPAN style="color:#00007F">In</SPAN>dicator" <SPAN style="color:#00007F">Then</SPAN><br>        <SPAN style="color:#007F00">'turn off autofilter</SPAN><br>        ActiveSheet.AutoFilterMode = <SPAN style="color:#00007F">False</SPAN><br>        <SPAN style="color:#007F00">'sets column L as a percentage column and calculates percentage for each row</SPAN><br>        Range("L1").Value2 = "Rebate %"<br>        <SPAN style="color:#00007F">With</SPAN> Percent<br>            .Style = "Percent"<br>            .Font.Name = "Arial"<br>            .Font.Size = 9<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>        <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cell <SPAN style="color:#00007F">In</SPAN> Percent<br>            <SPAN style="color:#00007F">If</SPAN> cell.Offset(0, -3).Value2 = 0 <SPAN style="color:#00007F">Then</SPAN><br>                cell.Value2 = "N/A"<br>            <SPAN style="color:#00007F">Else</SPAN><br>                cell.Value2 = cell.Offset(0, -2).Value2 / cell.Offset(0, -3).Value2<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <SPAN style="color:#00007F">Next</SPAN><br>        <SPAN style="color:#007F00">' for records where the Gender is not specified populates a the gender field based on Title Criteria</SPAN><br>        <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>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Select</SPAN><br>        <SPAN style="color:#00007F">Next</SPAN> cell<br>        <SPAN style="color:#007F00">'removes all records that are not "CL" (customer) or "PT" (partner)</SPAN><br>        <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cell <SPAN style="color:#00007F">In</SPAN> Role<br>            <SPAN style="color:#00007F">If</SPAN> cell.Value2 = "CL" <SPAN style="color:#00007F">Or</SPAN> cell.Value2 = "PT" <SPAN style="color:#00007F">Then</SPAN> <SPAN style="color:#007F00">'Identifies each cell for which the</SPAN><br>            <SPAN style="color:#007F00">'claim role is CL or PT</SPAN><br>            <SPAN style="color:#00007F">Else</SPAN><br>                cell.ClearContents <SPAN style="color:#007F00">' If claim role is other than CL or PT, clear the contents of that cell</SPAN><br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <SPAN style="color:#00007F">Next</SPAN><br>        Role.SpecialCells(xlCellTypeBlanks).EntireRow.Delete <SPAN style="color:#007F00">' Delete all rows where the Role cell is blank</SPAN><br>        <SPAN style="color:#007F00">'looks through age column and marks rows as pensioner or non-pensioner depending on age and gender</SPAN><br>        <SPAN style="color:#007F00">'if record is identified as being a pensioner code searches rest of claim column for the</SPAN><br>        <SPAN style="color:#007F00">'same claim reference and marks that as pensioner too</SPAN><br>        <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cell In Age<br>            <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:#007F00">'                            With Range(Cells(cell.Row, 2), (Cells(cell.Row, 12))).Interior</SPAN><br><SPAN style="color:#007F00">'                                    .Pattern = xlSolid</SPAN><br><SPAN style="color:#007F00">'                                    .PatternColorIndex = 2</SPAN><br><SPAN style="color:#007F00">'                                    .ThemeColor = xlThemeColorAccent5</SPAN><br><SPAN style="color:#007F00">'                                    .TintAndShade = 0.799981688894314</SPAN><br><SPAN style="color:#007F00">'                                    .PatternTintAndShade = 0</SPAN><br><SPAN style="color:#007F00">'                            End With</SPAN><br>                            Range(Cells(cell.Row, 2), (Cells(cell.Row, 12))).<SPAN style="color:#00007F">In</SPAN>terior.ColorIndex = 2 <SPAN style="color:#007F00">'''  </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><br>        <SPAN style="color:#00007F">Next</SPAN><br>        <SPAN style="color:#007F00">'looks through the column used to mark non-pensioner claims and marks the next column as pensioner claims</SPAN><br>        <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> cell In NonPensioner<br>            <SPAN style="color:#00007F">If</SPAN> cell.Value2 <> vbNullString <SPAN style="color:#00007F">Then</SPAN><br>                cell.Offset(0, 1).Value2 = vbNullString<br>            <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br>        <SPAN style="color:#00007F">Next</SPAN><br>        <SPAN style="color:#007F00">'copies the sheet and names the second sheet as the pensioner sheet</SPAN><br>        Sheets(1).Name = "Non-Pensioner"<br>        ActiveSheet.Copy After:=Sheets(Sheets.Count)<br>        ActiveSheet.Name = "Pensioner Only"<br>        ActiveSheet.AutoFilterMode = <SPAN style="color:#00007F">False</SPAN><br>        Sheets(1).Activate<br>        <SPAN style="color:#007F00">'deletes all records in the non-pensioner sheet that are pensioner claims and deletes the mark-up columns</SPAN><br>        NonPensioner.SpecialCells(xlCellTypeBlanks).EntireRow.Delete<br>        Range("M:N").Delete<br>        <SPAN style="color:#00007F">With</SPAN> ActiveSheet.Sort<br>            .SortFields.Clear<br>            .SortFields.Add Key:=Range("D2:D" & TotalRows), SortOn:=xlSortOnValues, Order:=xlAscending, _<br>                    DataOption:=xlSortNormal<br>            .SetRange Range("B1:L" & TotalRows)<br>            .Header = xlYes<br>            .MatchCase = <SPAN style="color:#00007F">False</SPAN><br>            .Orientation = xlTopToBottom<br>            .SortMethod = xlPinYin<br>            .Apply<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>        ActiveSheet.Range("$A$1:$L$" & TotalRows).RemoveDuplicates Columns:=2, Header:=xlYes<br>        <SPAN style="color:#007F00">'selects the pensioner sheet and sets relevant ranges</SPAN><br>        Sheets(2).Select<br>        TotalRows = ActiveSheet.UsedRange.Rows.Count<br>    <SPAN style="color:#00007F">Set</SPAN> Claims = Range("B2:B" & TotalRows)<br>    <SPAN style="color:#00007F">Set</SPAN> Age = Range("G2:G" & TotalRows)<br>    <SPAN style="color:#00007F">Set</SPAN> Role = Range("D2:D" & TotalRows)<br>    <SPAN style="color:#00007F">Set</SPAN> Sex = Range("F2:F" & TotalRows)<br>    <SPAN style="color:#00007F">Set</SPAN> Passported = Range("K2:K" & TotalRows)<br>    <SPAN style="color:#00007F">Set</SPAN> Title = Range("E2:E" & TotalRows)<br>    <SPAN style="color:#00007F">Set</SPAN> Percent = Range("L2:L" & TotalRows)<br>    <SPAN style="color:#00007F">Set</SPAN> NonPensioner = Range("M2:M" & TotalRows)<br>    <SPAN style="color:#00007F">Set</SPAN> Pensioner = Range("N2:N" & TotalRows)<br>        <SPAN style="color:#007F00">'removes all the non-pensioner records</SPAN><br>        Pensioner.SpecialCells(xlCellTypeBlanks).EntireRow.Delete<br>        Range("M:N").Delete<br>        <SPAN style="color:#00007F">With</SPAN> ActiveSheet.Sort<br>            .SortFields.Clear<br>            .SortFields.Add Key:=Range("D2:D" & TotalRows), SortOn:=xlSortOnValues, Order:=xlAscending, _<br>                    DataOption:=xlSortNormal<br>            .SetRange Range("B1:L" & TotalRows)<br>            .Header = xlYes<br>            .MatchCase = <SPAN style="color:#00007F">False</SPAN><br>            .Orientation = xlTopToBottom<br>            .SortMethod = xlPinYin<br>            .Apply<br>        <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>        ActiveSheet.Range("$A$1:$L$" & TotalRows).RemoveDuplicates Columns:=2, Header:=xlYes<br><SPAN style="color:#007F00">'GoTo CleanUp:</SPAN><br>    <SPAN style="color:#00007F">Else</SPAN><br>        MsgBox "Stopping because file is not in required format"<br><SPAN style="color:#007F00">'GoTo CleanUp:</SPAN><br>    <SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">If</SPAN><br><br>CleanUp:<br>Application.DisplayAlerts = <SPAN style="color:#00007F">False</SPAN><br><SPAN style="color:#007F00">'Workbooks("Split Pension Age Claims 2.xlsm").Close</SPAN><br>Application.DisplayAlerts = <SPAN style="color:#00007F">True</SPAN><br>Application.DisplayFullScreen = <SPAN style="color:#00007F">False</SPAN><br>Application.DisplayFormulaBar = <SPAN style="color:#00007F">True</SPAN><br>ActiveWindow.DisplayWorkbookTabs = <SPAN style="color:#00007F">True</SPAN><br>ActiveWindow.DisplayHeadings = <SPAN style="color:#00007F">True</SPAN><br>ActiveWindow.DisplayGridlines = <SPAN style="color:#00007F">False</SPAN><br>ActiveWindow.DisplayHorizontalScrollBar = <SPAN style="color:#00007F">True</SPAN><br>ActiveWindow.DisplayVerticalScrollBar = <SPAN style="color:#00007F">True</SPAN><br>Application.ScreenUpdating = screenUpdateState<br>Application.DisplayStatusBar = statusBarState<br>Application.Calculation = calcState<br>Application.EnableEvents = eventsState<br>ActiveSheet.DisplayPageBreaks = displayPageBreaksState <SPAN style="color:#007F00">'note this is a sheet-level setting</SPAN><br>end_time = Now()<br>MsgBox (DateDiff("s", start_time, end_time))<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN><br><br></FONT>

 

[Biz]

Hi Biz
the OP already has them in the code.....see Post # 1

Sorry missed it.

 

[Biz]

Thanks Michael ,



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

Hi Jeff,

With Application
.
.
End with

To speed up new code

Biz

 

[Michael M]

Biz
apologies back at ya....I see what you mean with the

With Application.

 

[Biz]

Biz
apologies back at ya....I see what you mean with the

With Application.

It's kwel m8.

Biz

 

[repairman615]

Hello Biz,


That is neat, tidy, and a better way to code that. Nice!

I think the OP should use that for sure.


Not sure why, I also didn't catch what you were saying in your first post.
After rereading, you were perfectly clear.

 

[Biz]

Hello Biz,


That is neat, tidy, and a better way to code that. Nice!

I think the OP should use that for sure.


Not sure why, I also didn't catch what you were saying in your first post.
After rereading, you were perfectly clear.

**** it I got busted as English is my third language.

Biz

 

[Michael M]

Couple more changes
REMEMBER TO TRY CHANGES ON TEST SHEETS

Sub latest2()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim start_time, end_time
start_time = Now()
'turn off some Excel functionality so code runs faster
    With Application
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ActiveSheet.DisplayPageBreaks = False
    End With
'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:N1").Value = [{"Non-Pensioner","Pensioner"}]
'checks that the data is set out in the columns as expected in order for code to work etc
    If Range("B1:K1").Value = [{"Current Claim Number","Tenure Type","Claim Role","Title","Gender","Age","Gross Liability","Rent Used in Calculation","Latest Weekly Entitlement","Income Support Indicator"}] Then
        'turn off autofilter
        ActiveSheet.AutoFilter
        'sets column L as a percentage column and calculates percentage for each row
        Range("L1").Value = "Rebate %"
        With Column("L:L") 'find last row and apply to range so it doesn't do entire column
            .Style = "Percent"
            .Font.Name = "Arial"
            .Font.Size = 9
        End With
        For Each cell In Percent 'change to cell In range("L2:L" & lastrow)
            If cell.Offset(0, -3).Value = 0 Then
                cell.Value = "N/A"
             End If
             cell.Value = cell.Offset(0, -2).Value / cell.Offset(0, -3).Value
        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).Value = "Male"
                Case " MRS", "MISS", "MRS", "MRS.", "MS", "MISS.", " MISS", " MS"
                    cell.Offset(0, 1).Value = "Female"
            End Select
        Next cell
        'removes all records that are not "CL" (customer) or "PT" (partner)
        For Each cell In Role
            If cell.Value = "CL" Or cell.Value = "PT" Then 'Identifies each cell for which the
            'claim role is CL or PT
            End If
              cell.ClearContents ' If claim role is other than CL or PT, clear the contents of that cell
        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).Value
                            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).Value
                        cell.Offset(0, 6).ClearContents
                        NonPensioner.Replace what:=ClaimRef, replacement:=vbNullString
                Case Is > 64
                    ClaimRef = cell.Offset(0, -5).Value
                    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.Value <> vbNullString Then cell.Offset(0, 1).Value = vbNullString
        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.AutoFilter
        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 'may not need these
            .Orientation = xlTopToBottom 'may not need these
            .SortMethod = xlPinYin 'may not need
            .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 'may not need
            .Orientation = xlTopToBottom ' may not need
            .SortMethod = xlPinYin 'may not need
            .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:
With Application
.DisplayAlerts = True
.DisplayFullScreen = False
.DisplayFormulaBar = True
End With
With ActiveWindow
.DisplayWorkbookTabs = True
.DisplayHeadings = True
.DisplayGridlines = True
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
End With
ActiveSheet.DisplayPageBreaks = displayPageBreaksState 'note this is a sheet-level setting
end_time = Now()
MsgBox (DateDiff("s", start_time, end_time))
End Sub

 

[Michael M]

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