Faster calculation on ranking on vba

[dellzy]

Hye,


I have coded the below as macros. It works successfully, just that consumes inconsiderable amount of time to process even just for 20 to 30 rows of data.


Appreciate if anyone who is expert to correct or improve my coding below to allow much faster processing :-

Sub Rank()
Dim FPart1 As String
Dim FPart2 As String
Dim FPart3 As String
Dim LRow As Integer
Dim SRow As Integer
Application.ScreenUpdating = False


OldRow = Range("E" & Rows.Count).End(xlUp).Row


LRow = Range("B" & Rows.Count).End(xlUp).Row
SRow = Range("A2").Value


ActiveSheet.Range("E" & SRow & ":E" & OldRow).ClearContents


FPart1 = "=IF(XXXXX<=R2C6,INDEX(INDIRECT(""$B$""&R2C1&"":$B$""&LOOKUP(2,1/(C[-3]<>""""),ROW(C[-3]))),MATCH(LARGE(YYYYY,ROWS(INDIRECT(CHAR(COLUMN()+64)&""$""&R2C1&"":""&CHAR(COLUMN()+64)&ROW()))),YYYYY,0)),IF(XXXXX<=R2C6+1,""All Other"",""""))"
FPart2 = "ROWS(INDIRECT(CHAR(COLUMN()+64)&""$""&R2C1&"":""&CHAR(COLUMN()+64)&ROW()))"
FPart3 = "INDIRECT(""$D$""&R2C1&"":$D$""&LOOKUP(2,1/(C[-3]<>""""),ROW(C[-3])))"


Application.ReferenceStyle = xlR1C1
    
With ActiveSheet.Range("E" & SRow)
.Formula = FPart1
.Replace "XXXXX", FPart2, lookat:=xlPart
.Replace "YYYYY", FPart3, lookat:=xlPart
End With


Application.ReferenceStyle = xlA1
Range("E" & SRow).Select
Selection.AutoFill Destination:=Range("E" & SRow & ":E" & LRow)
Calculate
Range("E" & SRow & ":E" & LRow).Select
Range("E" & SRow).Select
Application.ScreenUpdating = True
End Sub

 

[BQardi]

This should speed it up a bit

Sub Rank()
Dim FPart1 As String
Dim FPart2 As String
Dim FPart3 As String
Dim LRow As Integer
Dim SRow As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False

OldRow = Range("E" & Rows.Count).End(xlUp).Row
LRow = Range("B" & Rows.Count).End(xlUp).Row
SRow = Range("A2").Value

ActiveSheet.Range("E" & SRow & ":E" & OldRow).ClearContents

FPart1 = "=IF(ROWS(INDIRECT(CHAR(COLUMN()+64)&""$""&R2C1&"":""&"CHAR(COLUMN()+64)&ROW()))<=R2C6,INDEX(INDIRECT(""$B$""&R2C1&"":$B$""&LOOKUP(2,1/(C[-3]<>""""),ROW(C[-3]))),MATCH(LARGE(INDIRECT(""$D$""&R2C1&"":$D$""&LOOKUP(2,1/(C[-3]<>""""),ROW(C[-3]))),ROWS(INDIRECT(CHAR(COLUMN()+64)&""$""&R2C1&"":""&CHAR(COLUMN()+64)&ROW()))),INDIRECT(""$D$""&R2C1&"":$D$""&LOOKUP(2,1/(C[-3]<>""""),ROW(C[-3]))),0)),IF(ROWS(INDIRECT(CHAR(COLUMN()+64)&""$""&R2C1&"":""&CHAR(COLUMN()+64)&ROW()))<=R2C6+1,""All Other"",""""))"

Application.ReferenceStyle = xlR1C1
ActiveSheet.Range("E" & SRow).Formula = FPart1

Application.ReferenceStyle = xlA1
Range("E" & SRow).AutoFill Destination:=Range("E" & SRow & ":E" & LRow)
Range("E" & SRow).Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

It's possible that the formula could be made more effective, but I don't have the tools to look at this now...

 

[dellzy]

This should speed it up a bit

Sub Rank()
Dim FPart1 As String
Dim FPart2 As String
Dim FPart3 As String
Dim LRow As Integer
Dim SRow As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False

OldRow = Range("E" & Rows.Count).End(xlUp).Row
LRow = Range("B" & Rows.Count).End(xlUp).Row
SRow = Range("A2").Value

ActiveSheet.Range("E" & SRow & ":E" & OldRow).ClearContents

FPart1 = "=IF(ROWS(INDIRECT(CHAR(COLUMN()+64)&""$""&R2C1&"":""&"CHAR(COLUMN()+64)&ROW()))<=R2C6,INDEX(INDIRECT(""$B$""&R2C1&"":$B$""&LOOKUP(2,1/(C[-3]<>""""),ROW(C[-3]))),MATCH(LARGE(INDIRECT(""$D$""&R2C1&"":$D$""&LOOKUP(2,1/(C[-3]<>""""),ROW(C[-3]))),ROWS(INDIRECT(CHAR(COLUMN()+64)&""$""&R2C1&"":""&CHAR(COLUMN()+64)&ROW()))),INDIRECT(""$D$""&R2C1&"":$D$""&LOOKUP(2,1/(C[-3]<>""""),ROW(C[-3]))),0)),IF(ROWS(INDIRECT(CHAR(COLUMN()+64)&""$""&R2C1&"":""&CHAR(COLUMN()+64)&ROW()))<=R2C6+1,""All Other"",""""))"

Application.ReferenceStyle = xlR1C1
ActiveSheet.Range("E" & SRow).Formula = FPart1

Application.ReferenceStyle = xlA1
Range("E" & SRow).AutoFill Destination:=Range("E" & SRow & ":E" & LRow)
Range("E" & SRow).Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

It's possible that the formula could be made more effective, but I don't have the tools to look at this now...

Thanks a lot for the swift response, BQardi. It does help. Yea I agree there could be another way to do it but I'm just not expert enuff to come with that solution.

Thanks again.

 

[RickXL]

Hi,

I expect there are several people here who could help but who are not willing to invest the time in decoding your worksheet formula - particularly with no data to try it out on.

If you could describe in words what it is supposed to do I might be able to offer a wholly VBA solution. The problem with getting VBA to write out Worksheet formulas is that you end up with the worst of both worlds.

Regards,