Ordenação Automática de Linhas a partir do resultado (Ranking)

[lfpalma]

Boa tarde caros colegas,
Gostaria de uma ajuda, preciso criar uma planilha dinâmica onde, a partir do momento que insiro alguns dados de resultados, aconteça a ordenação automática.
Estou anexando a planilha com a explicação mais detalhada, mas vou tentar explicar melhor por aqui.

Uma loja de carros, por exemplo, uma lista de pessoas, com vários critérios de pontuação para se tornar o "Funcionário do Mês". A medida que são lançados os resultados das pessoas, preciso que a planilha vá ordenando, automaticamente, os pontuadores do maior para o menor (1º, 2º, 3º, 4º... do ranking).

Alguém poderia me ajudar?

Desde já, agradeço.

(vide anexo)

Abraço

[srobles]

Luis,

Amigo, adicione um novo módulo em sua pasta de trabalho e um botão na planilha.

No novo módulo, cole o código abaixo:

Código: Selecionar todos

Sub classificarFuncionario()
    'Desabilitamos a atualização de tela
    Application.ScreenUpdating = False
    'Selecionamos a planilha 1
    With ThisWorkbook.Sheets(1)
        .Activate
        'Selecionamos a primeira linha na coluna B
        Cells(1, 2).Select
        'Selecionamos a ultima linha linha preenchida
        Selection.End(xlDown).Select
        'Variável para armazenar a linha selecionada
        Dim ultimaLinha As Integer
        'Guardamos o numero da linha selecionada
        ultimaLinha = ActiveCell.Row
        
        'Aplicamos a classificação dos dados de acordo com a pontuação
        'Limpamos a classificação atual
        ActiveWorkbook.Worksheets("Folha1").Sort.SortFields.Clear
        'Definimos a nova classificação
        ActiveWorkbook.Worksheets("Folha1").Sort.SortFields.Add Key:=Range("K2:K" & ultimaLinha), _
            SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        
        'Aplicamos a classificação
        With ActiveWorkbook.Worksheets("Folha1").Sort
            .SetRange Range("A1:K" & ultimaLinha)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        Cells(2, "K").Select
        
        Dim linhaInicialEmpate As Integer
        Dim linhaFinalEmpate As Integer

        While ActiveCell <> ""
            If ActiveCell = Cells(ActiveCell.Row + 1, "K") Then
                While Cells(ActiveCell.Row, ActiveCell.Column) = Cells(ActiveCell.Row + 1, ActiveCell.Column)
                    linhaInicialEmpate = ActiveCell.Row
                    linhaFinalEmpate = ActiveCell.Row + 1
                    Cells(linhaFinalEmpate, ActiveCell.Column).Select
                Wend
                'Selecionamos o intervalo onde consta empate entre os funcionários                
                Range("A" & linhaInicialEmpate & ":K" & linhaFinalEmpate).Select
                'Limpamos a classificação atual novamente
                    ActiveWorkbook.Worksheets("Folha1").Sort.SortFields.Clear
                    'Definimos a nova classificação
                    ActiveWorkbook.Worksheets("Folha1").Sort.SortFields.Add Key:=Range("D" & linhaInicialEmpate & ":D" & linhaFinalEmpate), _
                        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
                    
                    'Aplicamos a classificação
                    With ActiveWorkbook.Worksheets("Folha1").Sort
                        .SetRange Range("A" & linhaInicialEmpate & ":K" & linhaFinalEmpate)
                        .Header = xlYes
                        .MatchCase = False
                        .Orientation = xlTopToBottom
                        .SortMethod = xlPinYin
                        .Apply
                    End With
                
            End If
            'Selecionamos a próxima linha
            Cells(ActiveCell.Row + 1, ActiveCell.Column).Select
        Wend
        
        'Definimos a posição de cada um de acordo com a posição na lista
        For vLinha = 2 To ultimaLinha
            Cells(vLinha, "L") = vLinha - 1 & "º"
        Next
        
    End With
    'Habilitamos a atualização de tela
    Application.ScreenUpdating = True
    
End Sub

Espero que te ajude.

Abs

[lfpalma]

Ajudou sim!
Mais uma vez, obrigado.
Abraço