✔ Programação GLOBAL®: MS Excel – Ordenando pastas Alfabéticamente

| Blog Office VBA | Blog Excel | Blog Access |

Quando me refiro a pasta, estou citando as worksheets das planilhas dentro de um mesmo arquivo workbook

É habitual a utilização de diversas pastas em um mesmo arquivo do MS Excel e, por decorrência, torna-se totalmente necessária que elas estejam organizadas por nome. Geralmente ocorre o contrário: Criamos várias pastas, ordenamos algumas e deixamos outras pelo caminho. No final estamos perdidos com várias pastas perdidas em nossas planilhas.

A funcionalidade que passo a seguir visa automatizar nossa necessidade de organização. Se dermos nomes adequados às nossas pastas, esta rotina fará todo o cansativo e enfadonho serviço de organização por nós, colocando-as em ordem alfabética.

Para ter suas pastas organizadas dentro das suas planilhas, basta que cole o código abaixo em um novo módulo da planilha que deseja organizar, fazendo chamadas a ele. Estas podem ser feitas na abertura e fechamento da mesma, ou através de um comando por combinação de teclas, um botão, ou o que desejar.

Use a imaginação!

Option Explicit

Function SheetsAlphaSort()

' Author: Date: Contact:

' André Bernardes 13/10/2008 11:07 bernardess@gmail.com

' Ordena de forma alfabética todas as pastas em uma planilha MS Excel.

Dim i As Integer

Dim j As Integer

Dim PrimPastaOrdenar As Integer

Dim UltiPastaOrdenar As Integer

Dim DescrescOrdem As Boolean

Let DescrescOrdem = False

If ActiveWindow.SelectedSheets.Count = 1 Then

'Altera o 1 para o número da pasta que deseja ordenar primeiro.

Let PrimPastaOrdenar = 1

Let UltiPastaOrdenar = Worksheets.Count

Else

With ActiveWindow.SelectedSheets

For i = 2 To .Count

If .Item(i - 1).Index <> .Item(i).Index - 1 Then

MsgBox "Não há como ordenar PASTAS não-adjacentes!"

Exit Sub

End If

Next i

Let PrimPastaOrdenar = .Item(1).Index

Let UltiPastaOrdenar = .Item(.Count).Index

End With

End If

For j = PrimPastaOrdenar To UltiPastaOrdenar

For i = j To UltiPastaOrdenar

If DescrescOrdem = True Then

If UCase(Worksheets(i).Name) > UCase(Worksheets(j).Name) Then

Worksheets(i).Move Before:=Worksheets(j)

End If

Else

If UCase(Worksheets(i).Name) < UCase(Worksheets(j).Name) Then

Worksheets(i).Move Before:=Worksheets(j)

End If

End If

Next i