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.
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.
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
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
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
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
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
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
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
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
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
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
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
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