VBA for Sorting of data

[Rahul87]

Dear Experts,
please help me out, Any Help would be highly appreciated, I am very much new to the VBA coding in excel and trying to short out some task in excel. I tried hard and found some codes step by step from internet and tried to achieve some of the task, but still unable to achieve the goal. Please help in achieving my goal. Below is full Description.

I have data in excel like this as in image

I want data to be sorted like below in the Image2 on the basis of Column E and ranking should be given in column H and Rank should starts from 1,2,3........ and if value in column E is 0.0% or null value then it should be given Rank at very last or kept at last of the record.

Below is the code in which I am struggling with, but unable to achieve the above task. Please help me to achieve the goal.

Sub SortAndRank()
    
    ' Define variables
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim sortRange As Range
    Dim rankRange As Range
    Dim i As Long
    Dim nullCount As Long
    
    ' Set worksheet object
    Set ws = ThisWorkbook.Sheets("Sheet2") ' Update with your sheet name
    
    ' Find last row of data in column A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Set range to sort (include headers)
    Set sortRange = ws.Range("A1:H" & lastRow)
    
    ' Move null or 0 values in column E to end of sorted range
    nullCount = Application.WorksheetFunction.CountIf(sortRange.Columns(5), "<>0") + _
                Application.WorksheetFunction.CountIf(sortRange.Columns(5), "")
    If nullCount > 0 Then
        sortRange.Sort Key1:=sortRange.Columns(5), Order1:=xlAscending, _
                        Key2:=sortRange.Columns(8), Order2:=xlAscending, Header:=xlYes
    End If
    
    ' Sort range by column E in descending order
    sortRange.Sort Key1:=sortRange.Columns(5), Order1:=xlDescending, _
                    Key2:=sortRange.Columns(8), Order2:=xlAscending, Header:=xlYes
    
    ' Set range to assign ranks (exclude headers)
    Set rankRange = ws.Range("H" & nullCount + 2 & ":H" & lastRow)
    
    ' Assign ranks and handle null or 0 values in column E
    If nullCount > 0 Then
        For i = 1 To lastRow - nullCount - 1
            If rankRange.Cells(i, 1) = rankRange.Cells(i + 1, 1) Then ' If values in column E are equal
                rankRange.Cells(i + 1, 1) = rankRange.Cells(i, 1) ' Set current cell equal to previous cell
            Else
                rankRange.Cells(i + 1, 1) = i + 1 - nullCount ' Set current cell to next rank
            End If
        Next i
        For i = lastRow - nullCount To lastRow - 1
            rankRange.Cells(i + 1, 1) = "" ' Clear any existing rank values
        Next i
    Else
        rankRange.Cells(1, 1) = 1 ' Set first cell in range to 1
        For i = 2 To lastRow - 1
            If rankRange.Cells(i, 1) = rankRange.Cells(i + 1, 1) Then ' If values in column E are equal
                rankRange.Cells(i + 1, 1) = rankRange.Cells(i, 1) ' Set current cell equal to previous cell
            Else
                rankRange.Cells(i + 1, 1) = i ' Set current cell to next rank
            End If
        Next i
    End If
    
End Sub

 

[Rahul87]

I suppose that you want to apply this new ordering method to the information that is in the column range K:R, right?...

Yes, Mario exactly , actually there are two types of sorting is going to be happened in the same sheet as you can see in the post and image also. I already uploaded the excel file also with image.

 

[Rahul87]

I see that the titles are no longer in row 1 but in row 2.

Yes it doesn't matter, that I have changed your given code as below and it is working very much perfect.

Sub SortAndRank()
Dim LR&
With Sheets("Sheet2")
  LR = .Cells(Rows.Count, "E").End(xlUp).Row
  .Range("I3:I" & LR) = "=(E3>0)*E3 + (E3<0)*(100-E3) + (E3=0)*4004"
  .Range("I3:I" & LR) = .Range("I3:I" & LR).Value
  .Range("A2:I" & LR).Sort .[i1], 1, , , , , , True
  .Range("H3") = 1: .Range("H3:H" & LR).DataSeries
  .Range("I3:I" & LR).Delete xlShiftUp
End With
End Sub

 

[Mario_R]

It is very similar to the previous one. I basically changed the formula.

Sub SortAndRank_2()
Dim LR&
With Sheets("Sheet2")
  LR = .Cells(2, "O").End(xlDown).Row
  .Range("R3:R" & LR) = "=(O3<0)*O3 + (O3>0)*(4-O3) + (O3=0)*4004"
  .Range("R3:R" & LR) = .Range("R3:R" & LR).Value
  .Range("K2:R" & LR).Sort .[R2], 1, , , , , , True
  .Range("R3") = 1: .Range("R3:R" & LR).DataSeries
End With
End Sub

 

[Rahul87]

It is very similar to the previous one. I basically changed the formula.

Sub SortAndRank_2()
Dim LR&
With Sheets("Sheet2")
  LR = .Cells(2, "O").End(xlDown).Row
  .Range("R3:R" & LR) = "=(O3<0)*O3 + (O3>0)*(4-O3) + (O3=0)*4004"
  .Range("R3:R" & LR) = .Range("R3:R" & LR).Value
  .Range("K2:R" & LR).Sort .[R2], 1, , , , , , True
  .Range("R3") = 1: .Range("R3:R" & LR).DataSeries
End With
End Sub

Thank you very much from my heart, it was highly appreciated @Mario_R . Can you please assist me if I want to run both the code at the same time if possible ?

 

[Mario_R]

Can you please assist me if I want to run both the code at the same time if possible ?

Sub Macro8()
  SortAndRank
  SortAndRank_2
End Sub

 

[Rahul87]

Sub Macro8()
  SortAndRank
  SortAndRank_2
End Sub

Hi @Mario_R , How are you ? hope all is going well and this post finds you in happiest day.

Mario, as per your given code, I was able to achieve goal, but again there was one more demand came and I modified your given code and was able to sort the data as per requirement, which you can find below, but now, I am struggling on how not to sort those data which are in column C and column M having 0 or null value should be kept at last in both parts, means actually sorting needs to be done as per below codes only, but one more thing is that if there is no value or 0 value is there in column C and Column M, then it should give very last rank or should be kept at last only on both sorting codes.

Below code is sorting and working fine.

Sub SortAndRank()
    Dim LR&
    With Sheets("Sheet2")
        LR = .Cells(Rows.Count, "E").End(xlUp).Row
        .Range("I3:I" & LR).Formula = "=IF(E3>=0,E3,-E3)"
        .Range("I3:I" & LR).Value = .Range("I3:I" & LR).Value
        .Range("A2:I" & LR).Sort .Range("I3"), xlDescending, , , , , , xlYes
        .Range("H3") = 1: .Range("H3:H" & LR).DataSeries
        .Range("I3:I" & LR).Delete xlShiftUp
    End With
End Sub

Sub SortAndRank_2()
    Dim LR As Long
    With Sheets("Sheet2")
        LR = .Cells(2, "O").End(xlDown).Row
        .Range("R3:R" & LR).Value = .Range("O3:O" & LR).Value
        .Range("K2:R" & LR).Sort .Range("R3"), xlAscending, , , , , , xlYes
        .Range("R3").Value = -3
         Range("R3") = 1: .Range("R3:R" & LR).DataSeries
        .Range("S3:S" & LR).Delete xlShiftUp
End With

End Sub

Sub SortingSS()
SortAndRank
SortAndRank_2
End Sub

Can you please add something on above, so that it should check in column C and column M, that if there is no or 0 value then it should be kept at very last on the rank.