none
MÉTODO DE ORDENAÇÃO? RRS feed

  • Pergunta

  • ESTE MÉTODO ESTÁ DEMORANDO MUITO.

    ALGUÉM TEM ALGUM CÓDIGO MAIS EFICIENTE?

            INI = 2
            FIM = SHLIST1.UsedRange.Rows.Count
            For I = INI To FIM - 1
                For J = I + 1 To FIM
                    If SHLIST1.Cells(I, 1) > SHLIST1.Cells(J, 1) Then
                        MENOR = SHLIST1.Cells(J, 1)
                        MENOR1 = SHLIST1.Cells(J, 2)
                        MENOR2 = SHLIST1.Cells(J, 3)
                        MENOR3 = SHLIST1.Cells(J, 4)
                        MENOR4 = SHLIST1.Cells(J, 5)
                        SHLIST1.Cells(J, 1) = SHLIST1.Cells(I, 1)
                        SHLIST1.Cells(J, 2) = SHLIST1.Cells(I, 2)
                        SHLIST1.Cells(J, 3) = SHLIST1.Cells(I, 3)
                        SHLIST1.Cells(J, 4) = SHLIST1.Cells(I, 4)
                        SHLIST1.Cells(J, 5) = SHLIST1.Cells(I, 5)
                        SHLIST1.Cells(I, 1) = MENOR
                        SHLIST1.Cells(I, 2) = MENOR1
                        SHLIST1.Cells(I, 3) = MENOR2
                        SHLIST1.Cells(I, 4) = MENOR3
                        SHLIST1.Cells(I, 5) = MENOR4
                    End If
                Next J
            Next I

    sexta-feira, 5 de junho de 2015 16:56

Respostas

  • Sub ORDENAR()

     INTER = Replace(Sheets("LST1").UsedRange.Address, "$A$1", "$A$2")

    Sheets("LST1").Select
        Range("A2").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        ActiveWorkbook.Worksheets("LST1").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("LST1").Sort.SortFields.Add Key:=Range("A2"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
           
      
        With ActiveWorkbook.Worksheets("LST1").Sort
            .SetRange Range(INTER)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End Sub



    sexta-feira, 5 de junho de 2015 18:09