Change filtering column in an existing code

[kelly mort]

Hello ,

This code is to rank data from my table

Section | Score 1 | Score 2 | Score 3 | Rank 1 | Rank 2 | Rank 3 |

It's doing that nicely. However, I want to switch the section from column A to C. So that my new table looks like :

| Index | Name | Section | Score 1 | Score 2 | Score 3 | Rank 1 | Rank 2 | Rank 3 |

I have been trying to fix that for a while now but I can't get it working.

Can someone fix that for me?

Option Explicit


Sub RankScoresBySection()




    Dim dicSection As Object
    Dim vItem As Variant
    Dim wsData As Worksheet
    Dim vSection As Variant
    Dim rScore As Range
    Dim rCell As Range
    Dim Score As Variant
    Dim Rnk As Double
    Dim LastRow As Long
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    Set wsData = ActiveSheet
    
    With wsData
        If .FilterMode Then .ShowAllData
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    If LastRow > 1 Then
        'Data exists
    Else
        MsgBox "No data exists!", vbExclamation
        Exit Sub
    End If
    
    On Error GoTo ErrHandler
    
    Set dicSection = CreateObject("Scripting.Dictionary")
    dicSection.CompareMode = 1 'vbTextCompare
    
    vSection = wsData.Range("A1:A" & LastRow).Value
    
    For i = LBound(vSection) + 1 To UBound(vSection)
        If Not dicSection.Exists(vSection(i, 1)) Then
            dicSection(vSection(i, 1)) = ""
        End If
    Next i
    
        For Each vItem In dicSection.keys()
        With wsData.UsedRange
            .AutoFilter field:=1, Criteria1:=vItem
            Set rScore = .Offset(1, 1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            For i = 0 To 2
                For Each rCell In rScore.Offset(, i)
                    Score = rCell.Value
                    If Application.IsNumber(Score) Then
                        Rnk = WorksheetFunction.Rank(CDbl(Score), rScore.Offset(, i))
                        rCell.Offset(, 3).Value = Rnk & GetOrdinalSuffixForRank(Rnk)
                    End If
                Next rCell
            Next i
            .AutoFilter
        End With
    Next vItem
    
ErrHandler:
    If Err <> 0 Then
        wsData.AutoFilterMode = False
        MsgBox "Error " & Err.Number & ":" & vbCrLf & vbCrLf & Err.Description, vbCritical, "Error"
    End If
    
    Application.ScreenUpdating = True
    
    Set dicSection = Nothing
    Set rScore = Nothing
    Set rCell = Nothing
    
End Sub

Function GetOrdinalSuffixForRank(Rnk As Double) As String


    Dim sSuffix As String
    
    If Rnk Mod 100 >= 11 And Rnk Mod 100 <= 20 Then
        sSuffix = "th"
    Else
        Select Case (Rnk Mod 10)
            Case 1
                sSuffix = "st"
            Case 2
                sSuffix = "nd"
            Case 3
                sSuffix = "rd"
            Case Else
                sSuffix = "th"
        End Select
        
    End If
    
    GetOrdinalSuffixForRank = sSuffix
    
End Function

 

[kelly mort]

I think i have fixed that:

    vSection = wsData.Range("[B]C1:C[/B]" & LastRow).Value
    
    For i = LBound(vSection) + 1 To UBound(vSection)
        If Not dicSection.Exists(vSection(i, 1)) Then
            dicSection(vSection(i, 1)) = ""
        End If
    Next i
    
        For Each vItem In dicSection.keys()
        With wsData.UsedRange
            .AutoFilter field:[B]=3,[/B] Criteria1:=vItem
            Set rScore = .Offset(1, 1).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
            For i = 0 To 2
                For Each rCell In rScore.Offset(, i)
                    Score = rCell.Value
                    If Application.IsNumber(Score) Then
                        Rnk = WorksheetFunction.Rank(CDbl(Score), rScore.Offset(, i))
                        rCell.Offset(, 3).Value = Rnk & GetOrdinalSuffixForRank(Rnk)
                    End If
                Next rCell
            Next i
            .AutoFilter
        End With
    Next vItem