Ajustar código

Anônima
2025-06-08T18:00:34+00:00

Prezados, 'herdei' a planilha anexa, e existe um código que lista primeiro cantores por ordem de classificação e depois por ordem de inscrição(Imagem anexo).

Alguém tem idéia de que ajuste devo fazer no código para que liste primeiro por ordem do número do cantor e depois por ordem de classificação? O inverso do que a rotina está fazendo

Public Function EmitirRelatorioPorCategoria() As Integer

Dim codCategoria As String

Dim bCategoriaEncontrada As Boolean

Dim celula As Range

Dim iContadorLinhaJurado As Integer

Dim iContadorJurados As Integer

Dim iContadorLinhaCategoria As Integer

Dim iContadorColunaCategoria As Integer

Dim iContadorLinhaClassificacao As Integer

Dim iLinhaPrimeiroCantor As Integer

Dim iLinhaUltimoCantor As Integer

Dim iContadorCantores As Integer

Dim iContadorCantoresAtivos As Integer

Dim aCantores(1000, 9) As Variant

Dim aCantoresOriginal(1000, 9) As Variant

Dim aNotasJurados(6, 4) As Currency

Dim ret As Variant

Dim sPrimColocados1 As String

Dim sPrimColocados2 As String

Dim iAux, iPosContador, iRowOffset, iCantorRow As Integer

Dim iQtdePremiados As Integer

Dim bProcurouJurados As Boolean

'Inicializar variaveis

bCategoriaEncontrada = False

iContadorCantores = 0

iAux = 0

iRowOffset = 0

iCantorRow = 0

iPosContador = 0

bProcurouJurados = False

'Inicializa Contadores Jurado (Conforme layout da planilha Relatorio)

' C7 -> Linha/coluna que tem o primeiro jurado

iContadorLinhaJurado = 7

iContadorJurados = 1

iContadorLinhaCategoria = 3

iContadorColunaCategoria = 8

iContadorLinhaClassificacao = 16

codCategoria = InputBox("Informe código da categoria:")

codCategoria = Trim(codCategoria)

If (codCategoria = "") Then

    MsgBox "Categoria Não informada", vbCritical

    Exit Function

End If

iQtdePremiados = InputBox("Informe Número de Premiados (Min.: 1 Max:10):")

If (iQtdePremiados < 1 Or iQtdePremiados > 10) Then

    MsgBox "Número de Premiados deve ser maior que 0 e menor que 11", vbCritical

    Exit Function

End If

'Limpa relatorios anteriores

ActiveWorkbook.Worksheets("Relatorio").Select

Rows("21:5000").Select

Selection.Delete Shift:=xlUp

Range("A1").Select

Range("A7:J12").Select

Selection.ClearContents

Range("J13").Select

Selection.ClearContents

Range("G13").Select

Selection.ClearContents

Range("A16:J17").Select

Selection.ClearContents

'Seleciona a sheet de notas

ActiveWorkbook.Worksheets("Cantores").Select

'Primeiro, localiza a categoria em questão

For Each celula In Range("E3:E1000")

    If (Trim(celula.Value) = codCategoria) Then

        bCategoriaEncontrada = True

        celula.Select

        iLinhaPrimeiroCantor = ActiveCell.Row

        Exit For

    End If

Next

If (Not bCategoriaEncontrada) Then

    MsgBox "Categoria Não Encontrada", vbCritical

    Exit Function

End If

'Preenche a categoria

ActiveWorkbook.Worksheets("Relatorio").Cells(iContadorLinhaCategoria, iContadorColunaCategoria) = ProcurarCategoria(codCategoria)

'Cria um vetor com os valores

For Each celula In Range(Cells(iLinhaPrimeiroCantor, 5), Cells(1000, 5))

    If (Trim(celula.Value) = codCategoria) Then

        aCantores(iContadorCantores, 0) = Cells(celula.Row, 1)

        aCantores(iContadorCantores, 1) = Cells(celula.Row, 6)

        aCantores(iContadorCantores, 2) = Cells(celula.Row, 7)

        aCantores(iContadorCantores, 3) = Cells(celula.Row, 8)

        aCantores(iContadorCantores, 4) = Cells(celula.Row, 9)

        aCantores(iContadorCantores, 5) = Cells(celula.Row, 10)

        aCantores(iContadorCantores, 6) = Cells(celula.Row, 11)

        aCantores(iContadorCantores, 7) = Cells(celula.Row, 12)

        aCantores(iContadorCantores, 8) = celula.Row

        'Preenche os jurados, uma unica vez...

        If bProcurouJurados = False Then

            If (Cells(celula.Row, 6) > 0 Or \_

                Cells(celula.Row, 7) > 0 Or \_

                Cells(celula.Row, 8) > 0 Or \_

                Cells(celula.Row, 9) > 0 Or \_

                Cells(celula.Row, 10) > 0 Or \_

                Cells(celula.Row, 11) > 0) Then

                For iContador = 6 To 11 Step 1

                    If (Cells(celula.Row, iContador).Value > 0) Then

                        ActiveWorkbook.Worksheets("Relatorio").Cells(iContadorLinhaJurado, 1) = iContadorJurados

                        ActiveWorkbook.Worksheets("Relatorio").Cells(iContadorLinhaJurado, 2) = "-"

                        ActiveWorkbook.Worksheets("Relatorio").Cells(iContadorLinhaJurado, 3) = ProcurarJurado(Cells(2, iContador).Value)

                        iContadorJurados = iContadorJurados + 1

                        iContadorLinhaJurado = iContadorLinhaJurado + 1

                    End If

                Next

                bProcurouJurados = True

            End If

        End If

        For iNotas = 6 To 11

            ' Armazena as estatísticas MAIOR

            If (Cells(celula.Row, iNotas) > 0 And \_

                (aNotasJurados(iNotas - 6, 0) = 0 Or Cells(celula.Row, iNotas) > aNotasJurados(iNotas - 6, 0))) Then

                aNotasJurados(iNotas - 6, 0) = Cells(celula.Row, iNotas)

            End If

            ' Armazena as estatísticas MENOR

            If (Cells(celula.Row, iNotas) > 0 And \_

                (aNotasJurados(iNotas - 6, 2) = 0 Or Cells(celula.Row, iNotas) < aNotasJurados(iNotas - 6, 2))) Then

                aNotasJurados(iNotas - 6, 2) = Cells(celula.Row, iNotas)

            End If

            ' Armazena as estatísticas SOMA TOTAL

            aNotasJurados(iNotas - 6, 3) = aNotasJurados(iNotas - 6, 3) + Cells(celula.Row, iNotas)

        Next

        If (Cells(celula.Row, 6) > 0 Or Cells(celula.Row, 7) > 0 Or \_

            Cells(celula.Row, 8) > 0 Or Cells(celula.Row, 9) > 0 Or \_

            Cells(celula.Row, 10) > 0 Or Cells(celula.Row, 11) > 0) Then

            iContadorCantoresAtivos = iContadorCantoresAtivos + 1

        End If

        iContadorCantores = iContadorCantores + 1

        iLinhaUltimoCantor = celula.Row

    End If

Next

If (iContadorCantoresAtivos <= 0) Then

    MsgBox "Nenhum cantor com notas encontrado!", vbCritical

    Exit Function

End If

' Armazena as estatísticas Média

For iNotasJurados = 0 To 5

    aNotasJurados(iNotasJurados, 1) = Format(aNotasJurados(iNotasJurados, 3) / iContadorCantoresAtivos, "##0.00")

Next

'Ordena em ordem decrescente

ret = SelectionSort(aCantores, iContadorCantores - 1)

'Coloca a classificação de volta à planilha

For Each celula In Range(Cells(iLinhaPrimeiroCantor, 5), Cells(iLinhaUltimoCantor, 5))

    If (Trim(celula.Value) = codCategoria) Then

        For icont = 0 To iContadorCantores - 1

            If (aCantores(icont, 0) = Cells(celula.Row, 1)) Then

                Cells(celula.Row, 13) = icont + 1

                Exit For

            End If

        Next

    End If

Next

'Monta a string com os primeiros 10 colocados

For icont = 0 To 9

    If (aCantores(icont, 0) > 0) Then

        If (aCantores(icont, 1) > 0 Or aCantores(icont, 2) > 0 Or aCantores(icont, 3) > 0 Or \_

            aCantores(icont, 4) > 0 Or aCantores(icont, 5) > 0 Or aCantores(icont, 6) > 0) Then

            If (icont < 5) Then

                sPrimColocados1 = sPrimColocados1 & "(" & icont + 1 & "º) " & aCantores(icont, 0) & " - " & Format(aCantores(icont, 7), "##0.00") & "   "

            Else

                sPrimColocados2 = sPrimColocados2 & "(" & icont + 1 & "º) " & aCantores(icont, 0) & " - " & Format(aCantores(icont, 7), "##0.00") & "   "

            End If

        End If

    Else

        Exit For

    End If

Next

'(1º) 114 - 269,90   (2º) 113 - 269,80   (3º) 112 - 265,00   (4º) 111 - 264,00   (5º)  110 - 262,00

'(6º) 114 - 269,90   (7º) 113 - 269,80   (8º) 112 - 265,00   (9º) 111 - 264,00   (10º) 110 - 262,00

ActiveWorkbook.Worksheets("Relatorio").Select

Cells(iContadorLinhaClassificacao, 1) = sPrimColocados1

Cells(iContadorLinhaClassificacao + 1, 1) = sPrimColocados2

'Finalmente, lista os cantores no relatorio

For Each celula In ActiveWorkbook.Worksheets("Cantores").Range(ActiveWorkbook.Worksheets("Cantores").Cells(iLinhaPrimeiroCantor, 1), ActiveWorkbook.Worksheets("Cantores").Cells(iLinhaUltimoCantor, 1))

    If (Trim(ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 5)) = codCategoria) Then

        If (ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 6) > 0 Or \_

            ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 7) > 0 Or \_

            ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 8) > 0 Or \_

            ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 9) > 0 Or \_

            ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 10) > 0 Or \_

            ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 11) > 0) Then

            iPosContador = (iAux \* 20) + 1

            If (celula.Row <> iLinhaPrimeiroCantor) Then

                Range("A1:J20").Select

                Selection.Copy

                Range(Cells(iPosContador, 1), Cells(iPosContador, 1)).Select

                ActiveSheet.Paste

                'Merge para Centralizar o titulo do Campeonato

                Range(Cells(iPosContador, 2), Cells(iPosContador, 7)).Select

                With Selection

                    .HorizontalAlignment = xlCenter

                End With

                Selection.Merge

                'Merge para Centralizar o Titulo da Coluna 'Jurados'

                Range(Cells(iPosContador + 5, 1), Cells(iPosContador + 5, 6)).Select

                With Selection

                    .HorizontalAlignment = xlCenter

                End With

                Selection.Merge

                Range(Cells(iPosContador, 1), Cells(iPosContador, 1)).Select

                Application.CutCopyMode = False

            End If

            Cells(iPosContador + 2, 1) = ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 1)

            Cells(iPosContador + 2, 3) = ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 2)

            Cells(iPosContador + 3, 3) = ProcurarCidade(ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 4))

            iRowOffset = 0

            If (ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 6) > 0) Then

                Cells(iPosContador + 6 + iRowOffset, 7) = ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 6)

                Cells(iPosContador + 6 + iRowOffset, 8) = aNotasJurados(0, 0)

                Cells(iPosContador + 6 + iRowOffset, 9) = aNotasJurados(0, 1)

                Cells(iPosContador + 6 + iRowOffset, 10) = aNotasJurados(0, 2)

                iRowOffset = iRowOffset + 1

            End If

            If (ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 7) > 0) Then

                Cells(iPosContador + 6 + iRowOffset, 7) = ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 7)

                Cells(iPosContador + 6 + iRowOffset, 8) = aNotasJurados(1, 0)

                Cells(iPosContador + 6 + iRowOffset, 9) = aNotasJurados(1, 1)

                Cells(iPosContador + 6 + iRowOffset, 10) = aNotasJurados(1, 2)

                iRowOffset = iRowOffset + 1

            End If

            If (ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 8) > 0) Then

                Cells(iPosContador + 6 + iRowOffset, 7) = ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 8)

                Cells(iPosContador + 6 + iRowOffset, 8) = aNotasJurados(2, 0)

                Cells(iPosContador + 6 + iRowOffset, 9) = aNotasJurados(2, 1)

                Cells(iPosContador + 6 + iRowOffset, 10) = aNotasJurados(2, 2)

                iRowOffset = iRowOffset + 1

            End If

            If (ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 9) > 0) Then

                Cells(iPosContador + 6 + iRowOffset, 7) = ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 9)

                Cells(iPosContador + 6 + iRowOffset, 8) = aNotasJurados(3, 0)

                Cells(iPosContador + 6 + iRowOffset, 9) = aNotasJurados(3, 1)

                Cells(iPosContador + 6 + iRowOffset, 10) = aNotasJurados(3, 2)

                iRowOffset = iRowOffset + 1

            End If

            If (ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 10) > 0) Then

                Cells(iPosContador + 6 + iRowOffset, 7) = ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 10)

                Cells(iPosContador + 6 + iRowOffset, 8) = aNotasJurados(4, 0)

                Cells(iPosContador + 6 + iRowOffset, 9) = aNotasJurados(4, 1)

                Cells(iPosContador + 6 + iRowOffset, 10) = aNotasJurados(4, 2)

                iRowOffset = iRowOffset + 1

            End If

            If (ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 11) > 0) Then

                Cells(iPosContador + 6 + iRowOffset, 7) = ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 11)

                Cells(iPosContador + 6 + iRowOffset, 8) = aNotasJurados(5, 0)

                Cells(iPosContador + 6 + iRowOffset, 9) = aNotasJurados(5, 1)

                Cells(iPosContador + 6 + iRowOffset, 10) = aNotasJurados(5, 2)

                iRowOffset = iRowOffset + 1

            End If

            Cells(iPosContador + 12, 7) = ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 12)

            Cells(iPosContador + 12, 10) = ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 13) & "º"

            iAux = iAux + 1

        End If

    End If

Next

'Inicia o segundo relatorio, em seguida:

iPosContador = 1

iRowOffset = 0

ActiveWorkbook.Worksheets("Resultado").Select

Cells(iPosContador + 1, 1) = "Classificação -  Categoria: "

Cells(iPosContador + 1, 3) = codCategoria

With Cells(iPosContador + 1, 3).Font

    .Name = "Arial"

    .Size = 14

    .Strikethrough = False

    .Superscript = False

    .Subscript = False

    .OutlineFont = False

    .Shadow = False

    .Underline = xlUnderlineStyleNone

    .ColorIndex = 1

End With

Cells(iPosContador + 3, 1) = "Ordem de classificação:"

iRowOffset = 6

Rows("5:5000").Select

Selection.Delete Shift:=xlUp

Range("A1").Select

'Lista os classificados em ordem de classificação

For iPosVetor = 0 To (iQtdePremiados - 1)

    If (aCantores(iPosVetor, 0) > 0) Then

        If (aCantores(iPosVetor, 1) > 0 Or aCantores(iPosVetor, 2) > 0 Or aCantores(iPosVetor, 3) > 0 Or \_

            aCantores(iPosVetor, 4) > 0 Or aCantores(iPosVetor, 5) > 0 Or aCantores(iPosVetor, 6) > 0) Then

            iCantorRow = aCantores(iPosVetor, 8)

            ActiveWorkbook.Worksheets("Cantores").Select

            Range(Cells(iCantorRow, 1), Cells(iCantorRow, 4)).Select

            Selection.Copy

            ActiveWorkbook.Worksheets("Resultado").Select

            Range(Cells(iPosContador + iRowOffset, 1), Cells(iPosContador + iRowOffset, 1)).Select

            ActiveSheet.Paste

            Application.CutCopyMode = False

            Cells(iPosContador + iRowOffset, 5) = iPosVetor + 1

            ' Coloca a borda

            Range(Cells(iPosContador + iRowOffset, 1), Cells(iPosContador + iRowOffset, 5)).Select

            Selection.Borders(xlDiagonalDown).LineStyle = xlNone

            Selection.Borders(xlDiagonalUp).LineStyle = xlNone

            With Selection.Borders(xlEdgeLeft)

                .LineStyle = xlContinuous

                .Weight = xlThin

                .ColorIndex = xlAutomatic

            End With

            With Selection.Borders(xlEdgeTop)

                .LineStyle = xlContinuous

                .Weight = xlThin

                .ColorIndex = xlAutomatic

            End With

            With Selection.Borders(xlEdgeBottom)

                .LineStyle = xlContinuous

                .Weight = xlThin

                .ColorIndex = xlAutomatic

            End With

            With Selection.Borders(xlEdgeRight)

                .LineStyle = xlContinuous

                .Weight = xlThin

                .ColorIndex = xlAutomatic

            End With

            With Selection.Borders(xlInsideVertical)

                .LineStyle = xlContinuous

                .Weight = xlThin

                .ColorIndex = xlAutomatic

            End With

            'With Selection.Borders(xlInsideHorizontal)

            '    .LineStyle = xlContinuous

            '    .Weight = xlThin

            '    .ColorIndex = xlAutomatic

            'End With

            'Contador de linhas

            iRowOffset = iRowOffset + 1

        End If

    Else

        Exit For

    End If

Next

'Lista os classificados em ordem de inscrição

Cells(iPosContador + iRowOffset + 2, 1) = "Ordem de Número dos cantores:"

iRowOffset = iRowOffset + 4

For Each celula In ActiveWorkbook.Worksheets("Cantores").Range(ActiveWorkbook.Worksheets("Cantores").Cells(iLinhaPrimeiroCantor, 1), ActiveWorkbook.Worksheets("Cantores").Cells(iLinhaUltimoCantor, 1))

    If (Trim(ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 5)) = codCategoria) Then

        If (ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 6) > 0 Or \_

            ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 7) > 0 Or \_

            ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 8) > 0 Or \_

            ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 9) > 0 Or \_

            ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 10) > 0 Or \_

            ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 11) > 0) Then

            If (ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 13) > 0 And ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 13) <= iQtdePremiados) Then

                ActiveWorkbook.Worksheets("Cantores").Select

                Range(Cells(celula.Row, 1), Cells(celula.Row, 4)).Select

                Selection.Copy

                ActiveWorkbook.Worksheets("Resultado").Select

                Range(Cells(iPosContador + iRowOffset, 1), Cells(iPosContador + iRowOffset, 1)).Select

                ActiveSheet.Paste

                Application.CutCopyMode = False

                Cells(iPosContador + iRowOffset, 5) = ActiveWorkbook.Worksheets("Cantores").Cells(celula.Row, 13)

                ' Coloca a borda

                Range(Cells(iPosContador + iRowOffset, 1), Cells(iPosContador + iRowOffset, 5)).Select

                Selection.Borders(xlDiagonalDown).LineStyle = xlNone

                Selection.Borders(xlDiagonalUp).LineStyle = xlNone

                With Selection.Borders(xlEdgeLeft)

                    .LineStyle = xlContinuous

                    .Weight = xlThin

                    .ColorIndex = xlAutomatic

                End With

                With Selection.Borders(xlEdgeTop)

                    .LineStyle = xlContinuous

                    .Weight = xlThin

                    .ColorIndex = xlAutomatic

                End With

                With Selection.Borders(xlEdgeBottom)

                    .LineStyle = xlContinuous

                    .Weight = xlThin

                    .ColorIndex = xlAutomatic

                End With

                With Selection.Borders(xlEdgeRight)

                    .LineStyle = xlContinuous

                    .Weight = xlThin

                    .ColorIndex = xlAutomatic

                End With

                With Selection.Borders(xlInsideVertical)

                    .LineStyle = xlContinuous

                    .Weight = xlThin

                    .ColorIndex = xlAutomatic

                End With

                'Contador de linhas

                iRowOffset = iRowOffset + 1

            End If

        End If

    End If

Next

'Reposiciona para o topo

ActiveWorkbook.Worksheets("Relatorio").Select

Range("A1").Select

'Finalmente, visualliza impressao

ActiveWindow.SelectedSheets.PrintPreview

'Reposiciona para o topo

ActiveWorkbook.Worksheets("Resultado").Select

Range("A1").Select

'Finalmente, visualliza impressao

ActiveWindow.SelectedSheets.PrintPreview

'Volta para a guia de Macro

ActiveWorkbook.Worksheets("Macro").Select

Range("A1").Select

End Function

Microsoft 365 e Office | Excel | Para uso doméstico | Windows

Pergunta bloqueada. Essa pergunta foi migrada da Comunidade de Suporte da Microsoft. É possível votar se é útil, mas não é possível adicionar comentários ou respostas ou seguir a pergunta.

0 comentários

1 resposta

Classificar por: Mais útil
Mais útil Mais Novo Mais Antigo
  1. Anônima
    2025-06-09T05:24:45+00:00

    Esta resposta foi traduzida automaticamente. Como resultado, pode haver erros gramaticais ou palavras estranhas.

    Olá LUIS.

    Entendemos o problema que você está enfrentando. Infelizmente,  o VBA não é suportado no fórum Microsoft Answers. É mais adequado para publicação no Stack Overflow (somente em inglês). 

    Publique perguntas de programação VBA no Stack Overflow usando a tag vba, juntamente com quaisquer outras tags relevantes.

    Observe que o Stack Overflow tem diretrizes como exigir um título descritivo, uma declaração de problema completa e concisa e detalhes suficientes para reproduzir seu problema. Solicitações de recursos ou perguntas excessivamente amplas são consideradas fora do tópico.

    Isenção de responsabilidade: a Microsoft não oferece garantias e/ou garantias, implícitas ou não, e não é responsável pelas informações que você recebe dos sites vinculados de terceiros ou qualquer suporte relacionado à tecnologia. 

    Não poderei ajudá-lo, mas deixarei essa pergunta em aberto caso um de nossos incríveis voluntários tenha ideias para você.

    Espero que as informações acima possam ajudá-lo. Sinta-se à vontade para enviar uma mensagem se precisar de mais ajuda.

    Sinceramente

    Nam-D - MSFT | Especialista em Suporte da Comunidade Microsoft.

    Esta resposta foi útil?

    0 comentários