VBA: Variáveis das tabelas - funções úteis

VBA : Variables tableaux - fonctions utiles

Veja algumas funções operacionais nas variáveis das planilhas.

Introdução

O objetivo destes códigos é executar determinadas funções (filtro, tipo, etc.) do Excel, trabalhando apenas na RAM e não nas células. Isso ajuda a economizar tempo em seus procedimentos e macros. Essas funções estão prontas para uso. No entanto, se você descobrir algum erro, favor colocar no fórum. Recomendo que você ponha todas essas funções e procedimentos em um módulo, para que eles possam ser acessados facilmente em todas as suas pastas de trabalho. Um módulo completo está disponível no parágrafo de download. Para evitar repetir o que existe e foi muito bem feito, eu recomendo esta leitura (em francês) para se familiarizar com as variáveis de tabelas e sua sintaxe.

Como adicionar o Índice

Adicione um elemento (ou linha de elementos) a um array (1 ou 2 dimensões) e lhe atribuir um índice preciso. Retorna True se tudo correr bem, False e, caso contrário, uma mensagem de erro explícita.

Atenção:

Use a função: Nb_Dimensões

Leia fonte parcial (em francês)

Configurações

Tabela: deve ser declarada como Variante, e não como Variável de tabela, logo, sem os parênteses. Ex.: Dim minhaTab ou Dim MyTbl As Variant

Índice: deve ficar entre o primeiro índice da Tabela e o ultimo índice + 1

Textos:

No caso da Tabela com 1 dimensão não deve ser um Array (matriz) > 1 valor único, por exemplo Texto = "José"

No caso da Tabela com 2 dimensões deve ser um Array (matriz) > ex.: Textos = Array ("José", "João", "Luiz")

Public Function Adicione_Índice(ByRef Tabela As Variant, _
                                       Index As Long, _
                                       Textos As Variant) As Boolean

        Adicione_Índice = False
        If Index < LBound(Tabela) Or Index > UBound(Tabela) + 1 Then GoTo Erro_Índice 
        Select Case Nb_Dimensões(Tabela)
            Case 1
'===== o código atual, patenteado por ucfoutu no VBFrança, é o único proprietário  do  VBFrança
'=====VBFrance autoriza as cópias livres e uso a condição de deixar
'=====inseridas as três linhas comentadas
                'solução sem ReDim nem Preserve
                If Nb_Dimensões(Textos) > 0 Then GoTo Erro_Textos
                If Índice = UBound(Tabela) + 1 Then
                    Tabela(Índice - 1) = Índice (Index - 1) & Chr(0) & Chr(0)
                Else
                    Tabela(Index) = Chr(0) & Chr(0) & Tabela(Índice)
                End If
                Dim Tbl
                On Error GoTo Erro_Tabela
                    Tbl = Split(Replace(Join(Tabela, Chr(0)), Chr(0) & Chr(0), Chr(0)), Chr(0))
                    Tbl(Índice) = Textos
                    Tabela = Tbl
'=========================
                On Error GoTo 0
                Erase Tbl
                Adicione_Índice = True
            Case 2
                If Nb_Dimensões(Textos) = 1 Then
                    Dim tabela(), j As Long, i As Long
                    'solução com ReDim e Preserve
                    On Error GoTo Erro_Tabela
                        ReDim Preserve tabela(LBound(Tabela, 1) To UBound(Tabela, 1) + 1, LBound(Tabela, 2) To UBound(Tabela, 2))
                        For i = LBound(Tabela, 1) To Índice - 1
                            For j = LBound(Tabela, 2) To UBound(Tabela, 2)
                                tabela(i, j) = Tabela(i, j)
                            Next
                        Next
                        For i = Index To UBound(Tabela, 1)
                            For j = LBound(Tabela, 2) To UBound(Tabela, 2)
                                tabela(i + 1, j) = Tabela(i, j)
                            Next
                        Next
                        For j = LBound(Textos) To UBound(Textos)
                            tabl(Índice, j + 1) = Textos(j)
                        Next
                        Tabela = tabela
                    On Error GoTo 0
                    Erase tabl
                    Adicione_Índice = True
                Else
                    GoTo Erro_Textos
                End If
            Case Else
                MsgBox "Sua Tabela não comporta o número de dimensão adequado. Função não processada."
        End Select
        Exit Function
        
Erro_Tabela:
    MsgBox "Sua Tabela não foi declarada como convém."
    Exit Function
Erro_Textos:
    MsgBox "O último parâmetro da função não é válido."
    Exit Function
Erro_Índice:
    MsgBox "Índice inválido"
End Function

Extração_Coluna

Vai criar uma variável de tabela unidimensional a partir de uma variável de tabela multidimensional, extraindo os dados de uma coluna desta tabela. Portanto, retorna uma variável de tabela do tipo Variant unidimensional.

Atenção:

usa a função: Nb_Dimensões

Configurações

Tabela = Array de Variant com 2 dimensões

Coluna = número da coluna com os dados a serem extraídos

Public Function Extração_Coluna(ByVal Tabela As Variant, _
                                         Coluna As Long) As Variant

    Dim Tbl() As Variant, i As Long, TesteColuna As Variant
    
        On Error GoTo Erro_Coluna
        TesteColuna = Tabela(LBound(Tabela, 1), Coluna)
        On Error GoTo 0
        Select Case Nb_Dimensões(Tabela)
            Case 0
                MsgBox "A tabela configurada está vazia.": Exit Function
            Case 1
                MsgBox "A tabela configurada só tem uma coluna."
                Exit Function
            Case 2
                ReDim Tbl(UBound(Tabela, 1))
                For i = LBound(Tabela, 1) To UBound(Tabela, 1)
                    Tbl(i) = Tabela(i, Coluna)
                Next
        End Select
        Extração_Coluna = Tbl
        Erase Tbl
        Exit Function
Erro_Coluna:
        MsgBox "O parâmetro Coluna está errado."
End Function

Filtro_Tabela

Filtrar uma tabela com 2 dimensões em função do conteúdo de uma coluna.
Retorna uma tabela com 2 dimensões do tipo Variant.

Atenção:

usa as funções: Nb_Dimensões & Transposição

Configurações

Tabela= Array de Variant com 2 dimensões

Coluna= número da coluna com dados a serem filtrados

Key1= comparador, dado ao qual comparar os dados da coluna Coluna

Test= operador entre: "=", "<", "<=", ">", ">=", "Like", "<>" (a passar em String, ou seja, com aspas)

Public Function Filtro_Tabela(ByVal Tabela As Variant, _
                                         Coluna As Long, _
                                         Key1 As Variant, _
                                         Optional test As String = "=") As Variant
    
    Dim Tbl() As Variant, i As Long, j As Long, Cpt As Long, TesteColuna As Variant
    
        On Error GoTo Erro_Coluna
        TesteColuna = Tabela(LBound(Tabela, 1), Coluna)
        On Error GoTo 0
        Select Case Nb_Dimensões(Tabela)
            Case 0
                MsgBox "A tabela configurada está vazia.": Exit Function
            Case 1
                MsgBox "A tabela configurada só tem uma coluna."
                Exit Function
            Caso 2
                Select Case test
                    Case "="
                        For i = LBound(Tabela, 1) To UBound(Tabela, 1)
                            If Tabela(i, Coluna) = Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tabela, 2) To UBound(Tabela, 2), LBound(Tabela, 1) To Cpt)
                                For j = LBound(Tabela, 2) To UBound(Tabela, 2)
                                    Tbl(j, Cpt) = Tabela(i, j)
                                Next j
                            End If
                        Next i
                    Case "<"
                        For i = LBound(Tabela, 1) To UBound(Tabela, 1)
                            If Tabela(i, Coluna) < Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tabela, 2) To UBound(Tabela, 2), LBound(Tabela, 1) To Cpt)
                                For j = LBound(Tabela, 2) To UBound(Tabela, 2)
                                    Tbl(j, Cpt) = Tabela(i, j)
                                Next j
                            End If
                        Next i
                    Case ">"
                        For i = LBound(Tabela, 1) To UBound(Tabela, 1)
                            If Tabela (i, Coluna) > Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tabela, 2) To UBound(Tabela, 2), LBound(Tabela, 1) To Cpt)
                                For j = LBound(  , 2) To UBound(Tabela, 2)
                                    Tbl(j, Cpt) = Tabela (i, j)
                                Next j
                            End If
                        Next i
                    Case "<="
                        For i = LBound(Tabela, 1) To UBound(Tabela, 1)
                            If Tabela(i, Coluna) <= Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tabela, 2) To UBound(Tabela, 2), LBound(Tabela, 1) To Cpt)
                                For j = LBound(Tabela, 2) To UBound(Tabela, 2)
                                    Tbl(j, Cpt) = Tabela(i, j)
                                Next j
                            End If
                        Next i
                    Case ">="
                        For i = LBound(Tabela, 1) To UBound(Tabela, 1)
                            If Tabela(i, Coluna) >= Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tabela, 2) To UBound(Tabela, 2), LBound(Tabela, 1) To Cpt)
                                For j = LBound(Tabela, 2) To UBound(Tabela, 2)
                                    Tbl(j, Cpt) = Tabela(i, j)
                                Next j
                            End If
                        Next i
                    Case "<>"
                        For i = LBound(Tabela, 1) To UBound(Tabela, 1)
                            If Tabela(i, Coluna) <> Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tabela, 2) To UBound(Tabela, 2), LBound(Tabela, 1) To Cpt)
                                For j = LBound(Tabela, 2) To UBound(Tabela, 2)
                                    Tbl(j, Cpt) = Tabela(i, j)
                                Next j
                            End If
                        Next i
                    Case "Like"
                        For i = LBound(Tabela, 1) To UBound(Tabela, 1)
                            If Tabela(i, Coluna) Like Key1 Then
                                Cpt = Cpt + 1
                                ReDim Preserve Tbl(LBound(Tabela, 2) To UBound(Tabela, 2), LBound(Tabela, 1) To Cpt)
                                For j = LBound(Tabela, 2) To UBound(Tabela, 2)
                                    Tbl(j, Cpt) = Tabela(i, j)
                                Next j
                            End If
                        Next i
                    Case Else
                        MsgBox "O parâmetro opcional Teste está errado."
                        Exit Function
                End Select
                On Error GoTo resultado_Vazio
                TesteColuna = Tbl(UBound(Tbl, 1), UBound(Tbl, 2))
                On Error GoTo 0
                Filtro_Tabela = Transposição(Tbl)
                Erase Tbl
            Case Else
                MsgBox "A tabela tem mais de duas dimensões. A função não se adapta a este caso."
        End Select
        Exit Function
Erro_Coluna:
    MsgBox "O parâmetro Coluna está errado."
    Exit Function
resultado_Vazio:
    MsgBox "O filtro retorna uma tabela vazia de dados."
End Function

Inversão_Tabela

Inverte os elementos de uma tabela (1 ou 2 dimensões). Os primeiros serão os últimos! Retorna True se tudo correr bem e, caso contrário, False + mensagem. Leia a Fonte

Atenção:

use a função: Nb_Dimensões

Configurações

Tabela= Array de Variant com 1 ou 2 dimensões

Public Function Inversão_Tabela(ByRef Tabela As Variant) As Boolean

    Dim Temp As Variant, IndexDeb As Long, IndexFin As Long, IndexDim2 As Long
    
        Inversão_Tabela= False
        Select Case Nb_Dimensões(Tabela)
            Case 0
                MsgBox "A tabela configurada está vazia."
            Case 1
                IndexFin= UBound(Tabela)
                For IndexDeb= LBound(Tabela) To ((UBound(Tabela) - LBound(Tabela) + 1) \ 2)
                    Temp= Tabela(ÍndiceCom)
                    Tabela(ÍndiceCom)= Tabela(ÍndiceFim)
                    Tabela(ÍndiceFim)= Temp
                    ÍndiceFim= ÍndiceFim - 1
                Next ÍndiceCom
                Inversão_Tabela= True
            Case 2
                ÍndiceFim= UBound(Tabela, 1)
                For ÍndiceCom= LBound(Tabela, 1) To ((UBound(Tabela, 1) - LBound(Tabela, 1) + 1) \ 2)
                    For ÍndiceDim2= LBound(Tabela, 2) To UBound(Tabela, 2)
                        Temp= Tabela (ÍndiceCom, ÍndiceDim2)
                        Tabela(ÍndiceCom, ÍndiceDim2) = Tabela(ÍndiceFim, IÍndiceDim2)
                        Tabela(ÍndiceFim, ÍndiceDim2) = Temp
                    Next ÍndiceDim2
                    ÍndiceFim= ÍndiceFim - 1
                Next ÍndiceCom
                Inversão_Tabela= True
            Case Else
                MsgBox "A tabela tem mais de duas dimensões."
        End Select
End Function

Nb_Dimensões

Calcula o número de dimensões de uma tabela. Retorna um Integer

Configurações

Tablela= Array de Variant com 0, 1 ou várias dimensões

Public Function Nb_Dimensões(Tabela As Variant) As Integer
    Dim D As Integer, t As Long
    
        On Error GoTo Fim
        Do: D = D + 1: t= UBound(Tabela, D): Loop
Fim:
    Nb_Dimensões= D - 1
End Function

Range_To_Tb

Converte uma fileira em tabela. Supera o problema encontrado se a Range (fileira) só tiver uma célula. Leia a Fonte (em francês). Retorna uma tabela, sempre em opção a base 1 e com 2 dimensões.

Configurações

Intervalo = Range (intervalo de célula(s))

Public Function Range_To_Tb(Intervalo As Range) As Variant()
        If Intervalo.Cells.Count < 2 Then
           Dim tabela(1 To 1, 1 To 1)
           tabela(1, 1)= Intervalo.Value
           Range_To_Tb= tabela
           Erase tabela
         Else
           Range_To_Tb= Intervalo.Value
         End If
End Function

Retorno_Índice

Determina o índice de um elemento a partir do seu conteúdo. Retorna um Long representando o índice deste item, -1 se o item não existir na tabela.

Atenção:

use a função: Nb_Dimensões

Leia a Fonte parcial (em francês).

Configurações

Tabela= Array de Variant com 1 ou 2 dimensões

Texto= Dado do tipo String a ser procurado na tabela na coluna Coluna

Coluna Opcional > indica a coluna da tabela ou procurar o valor Texto

Public Function Retourne_Index(ByVal Tabela As Variant, _
                                         Texto As String, _
                                         Coluna Opcional As Long = 1) As Long
    Dim i As Long, strTemp As String
    
        Retorna_Índice= -1
        Select Case Nb_Dimensões(Tabela)
            Case 0
                MsgBox "A tabela configurada está vazia."
            Case 1
'===== o código atual, patenteado por ucfoutu no VBFrança, é o único proprietário  do  VBFrança
'=====VBFrance autoriza as cópias livres e uso a condição de deixar
'=====inseridas as três linhas comentadas
                strTemp = Chr(0) & Join(Tabela, Chr(0)) & Chr(0)
                i = InStr(strTemp, Chr(0) & Texto & Chr(0))
                If i = 0 Then Retorna_Índice = -1: Exit Function
                strTemp = Mid(strTemp, 1, i)
                Retorna_Índice = UBound(Split(strTemp, Chr(0))) - 1
                If Retorna_Índice < 0 Then Retorna_Índice = -1
                Exit Function
'======================
            Case 2
                For i = LBound(Tabela, 1) To UBound(Tabela, 1)
                    If Tabela(i, Coluna) = Texto Then Retorna_Índice = i: Exit Function
                Next i
        End Select
End Function

Exclui_Índice

Remove um elemento (ou uma linha de elementos) por seu índice ou por seu conteúdo. Retorna uma tabela do tipo Variant.

Atenção:

use as funções: Retorna_Índice & Nb_Dimensões

Leia a Fonte parcial (em francês).

Configurações

Tabela = Array de Variant com 1 ou 2 dimensões

Texto_Ou_Índice = Dado do tipo Variant (String ("palavra" a ser procurada) ou Long (Índice da "palavra" a ser procurada)), a ser procurada na tabela

Coluna Opcional => Caso de um array com 2 dimensões: indica a coluna da tabela ou procurar o valor Texto_Ou_Índice

Public Function Exclui_ Índice(ByRef Tabela As Variant, _
                                         Texto_Ou_ Índice, _
                                         Coluna Opcional As Long = 1) As Variant
    Dim i As Long, Sucf As String
    
        If VarType(Texto_Ou_ Índice) = 8 Then
            Sucf = Texto_Ou_ Índice
            i = Retorna_ Índice (Tabela, Sucf, Coluna)
        Else
            i = Texto_Ou_ Índice
        End If
        If i >= 0 Then
            Select Case Nb_Dimensões(Tabela)
                Case 0
                    MsgBox "A tabela configurada está vazia."
                Case 1
'===== o código atual, patenteado por ucfoutu no VBFrança, é o único proprietário  do  VBFrança
'=====VBFrance autoriza as cópias livres e uso a condição de deixar
'=====inseridas as três linhas comentadas
                        Tabela(i) = ""
                        Sucf = Join(Tabela, Chr(0))
                        If i = 0 Then Sucf = Mid(Sucf, 2)
                        If i = UBound(Tabela) Then Sucf = Left(Sucf, Len(Sucf) - 1)
                        Exclui_Índice = Split(Replace(Sucf, Chr(0) & Chr(0), Chr(0)), Chr(0))
'==================
                Case 2
                    Dim j As Long, k As Long, Cpt As Long, Tbl
                        For j = LBound(Tabela, 1) To UBound(Tabela, 1) - 1
                            If j <> i Then
                                For k = LBound(Tabela, 2) To UBound(Tabela, 2)
                                    Cpt = Cpt + 1
                                    ReDim Preserve Tbl(1 To Cpt, 1 To k)
                                    Tbl(Cpt, k) = Tabela (j + 1, k)
                                Next k
                            End If
                        Next j
                        Exclui Índice = Tbl
                        Erase Tbl
                Case Else
                    MsgBox "A tabela tem mais de duas dimensões. A função não se adapta a este caso."
            End Select
        Else
            MsgBox "O valor a ser removido não foi encontrado na variável da tabela"
        End If
End Function

Transposição

A função Excel Transpose (ou em VBA “Application.Transpose”) se limita a 65.536 linhas. Este recurso supera essa falta para as grandes variáveis de tabelas. Retorna uma tabela do tipo Variant.

Atenção:

use a função: Nb_Dimensões

Configurações

Tabela = Array de Variant

Public Function Transposição(ByRef Tabela As Variant) As Variant
    Dim tabl, i As Long, j As Long
        
        Select Case Nb_Dimensões(Tabela)
            Case 0
                MsgBox "A tabela configurada está vazia."
            Case 1
                ReDim tabl(LBound(Tabela) To UBound(Tabela), LBound(Tabela) To 1)
                For i = LBound(Tabela) To UBound(Tabela)
                    tabl(i, LBound(Tabela)) = Tabela(i)
                Next
                Transposição = tabl
                Erase tabl
            Case 2
                ReDim tabl(LBound(Tabela, 2) To UBound(Tabela, 2), LBound(Tabela, 1) To UBound(Tabela, 1))
                For i = LBound(Tabela, 1) To UBound(Tabela, 1)
                    For j = LBound(Tabela, 2) To UBound(Tabela, 2)
                        tabl(j, i) = Tabela (i, j)
                    Next j
                Next i
                Transposição = tabl
                Erase tabl
            Case Else
                MsgBox "A tabela tem mais de duas dimensões"
        End Select
End Function

Tri_1_Dim

Ordena uma tabela de 1 dimensão. Retorna a tabela de Variant configurada. Baseada no QuickSort de Boisgontier http://boisgontierjacques.free.fr/ (em francês).

Configurações

Tabela = Array de Variant

mini = Índice inferior (ex: LBound(Tabela))

Maxi = Índice superior (ex: UBound(Tabela))

Public Sub Tri_1_Dim(ByRef Tabela As Variant, _
                               mini As Long, _
                               Maxi As Long)
   
    Dim i As Long, j As Long, Pivot As Variant, Temp As Variant
        
        On Error Resume Next
        i = mini: j = Maxi
        Pivot = Tabela((mini + Maxi) \ 2)
        While i <= j
            While Tabela(i) < Pivot And i < Maxi: i = i + 1: Wend
            While Pivot < Tableau(j) And j > mini: j = j - 1: Wend
            If i <= j Then
                Temp = Tabela(i)
                Tabela(i) = Tabela(j)
                Tabela(j) = Temp
                i = i + 1: j = j - 1
            End If
        Wend
        If (mini < j) Then Call Tri_1_Dim(Tabela, mini, j)
        If (i < Maxi) Then Call Tri_1_Dim(Tabela, i, Maxi)
End Sub

Tri_2_Dim

Ordena uma tabela de duas dimensões. Retorna a tabela de Variant configurada, classificada de acordo com a coluna dada em parâmetro. Leia a Fonte (em francês).

==Configurações===

Tabela = Array de Variant

mini = Índice inferior (ex: LBound(Tabela))

Maxi = Índice superior (ex: UBound(Tabela))

Coluna Opcional = a coluna de acordo com a que será classificada na tabela

Public Sub Tri_2_Dim(ByRef Tableau As Variant, _
                               mini As Long, _
                               Maxi As Long, _
                               Coluna Opcional As Long = 0)

    Dim i As Long, j As Long, Pivot As Variant, TabelaTemp As Variant, ColTemp As Long
    
        On Error Resume Next
        i = mini: j = Maxi
        Pivot = Tabela((mini + Maxi) \ 2, Coluna)
        While i <= j
            While Tabela(i, Coluna) < Pivot And i < Maxi: i = i + 1: Wend
            While Pivot < Tabela(j, Coluna) And j > mini: j = j - 1: Wend
            If i <= j Then
                ReDim TabelaTemp(LBound(Tabela, 2) To UBound(Tabela, 2))
                For ColTemp = LBound(Tabela, 2) To UBound(Tabela, 2)
                    TabelaTemp(ColTemp) = Tabela(i, ColTemp)
                    Tabela(i, ColTemp) = Tabela(j, ColTemp)
                    Tabela(j, ColTemp) = TabelaTemp(ColTemp)
                Next ColTemp
                Erase TabelaTemp
                i = i + 1: j = j - 1
            End If
        Wend
        If (mini < j) Then Call Tri_2_Dim(Tabela, mini, j, Coluna)
        If (i < Maxi) Then Call Tri_2_Dim(Tabela, i, Maxi, Coluna)
End Sub

Downloads

Você encontrará aqui, um módulo reunindo todas essas funções. Para integra-lo à sua pasta de trabalho após o download no VBA: Arquivo > Importar um arquivo.

Bom uso!
Foto: © Microsoft.com

Veja também

Artigo original publicado por pijaku. Tradução feita por pintuda. Última modificação: 12 de agosto de 2016 às 06:01 por ninha25.

VBA: como carregar fontes sem instalar com AddFontResource

VBA: como interceptar um Colar – Past Event