VBA: Variáveis das tabelas - funções úteis
Objetivo desses códigos é executar determinadas funções do Excel, trabalhando apenas na RAM e não nas células; isso ajuda a economizar tempo em procedimentos e macros. Veja algumas dessas funções.
Introdução
As funções a seguir estão prontas para uso. Recomendamos 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.
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 |
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 |
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 |
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 |
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
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. Retorna uma tabela, sempre em opção a base 1 e com 2 dimensõ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 |
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 |
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 |
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.
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.
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 integrá-lo à sua pasta de trabalho após o download no VBA: Arquivo > Importar um arquivo.
Foto: © Dzmitry Kliapitski - 123RF.com
- Tabela vba
- Funções prontas vba - Melhores respostas
- Vba tabela - Melhores respostas
- Tabela de cores vba excel - Dicas - Visual Basic
- Como copiar uma tabela de um site para o word - Dicas - Word
- Tabela verdade no excel - Dicas - Excel
- Tabela unicode - Dicas - Criptografia
- Tabela arp windows - Dicas - Internet
