Boa tarde pessoal,
Eu estava lendo alguns tópicos quando me deparei com o tópico do Mateus, que sugeria um VLOOKUP invertido. Adotei como um desafio para esta tarde maravilhosa e resolvi desenvolver como eu acho que deveria ser uma rotina de busca.
Então levantei as funções de busca "mais famosas" (não necessariamente as melhores), que são as do título e criei a minha num suplemento (XLAM) anexado no tópico e desprotegido para efeito didático. Detalhe, eu mencionei no título PROCVH(), mas essa função não existe, mas é que seria legal ter uma função que procurasse na vertical e retornasse da horizontal, ou vice versa, ou seja, é conceitual a coisa.
Certa vez resolvi avaliar a performance das funções de busca (DESLOC(), ÍNDICE(), PROCV() e PROC()) e descobri que a PROC() é a mais rápida de todas, sendo até 250 vezes mais veloz que todas as demais.
O PROC() possui limitações (coluna de busca necessariamente classificada em ordem crescente).
O PROCV() também possui limitações (coluna de busca necessariamente à esquerda, relativamente difícil de usar, etc)
O PROCH() também possui limitações (linha de busca necessariamente no topo, relativamente difícil de usar, etc).
Nenhuma delas retorna o segundo ou terceiro valor caso a coluna de busca tenha mais de uma aparição do valor procurado.
Diante destas limitações, resolvi criar uma UDF (User Defined Function) que fosse tão simples de usar quanto a PROC() mas sem a limitação dela, mas que oferecesse as facilidades que a PROCV() e a PROCH() tem, mas também sem as limitações (de posição da coluna de busca).
Venho então por meio da PROC2() reinventar as funções de busca. Adotei o nome da PROC(), pois a lista de parâmetros ficou praticamente igualzinha.
Abaixo, a descrição/documentação da função:
'---------------------------------------------------------------------------------------
' Rotina....: PROC2() / User Defined Function
' Versão....: v1.0
' Contato...: fernando.reis@mondial.com.br
' Empresa...: Mondial Tecnologia em Informática LTDA.
' Descrição.: Função Alternativa ao VLOOKUP ou LOOKUP ou HLOOKUP que efetua buscas na horizontal ou vertical
' ou em horizontal com valores verticais ou vice versa, e retorna todas as ocorrências do valor procurado
' Parâmetros:
' 1) Item procurado
' 2) Matriz onde o item será procurado
' 3) Matriz cujo resultado será retornado
' 4) Qual ocorrência do item deve ter seu equivalente retornado
'
' Observações:
' 1) Ambas as matrizes precisam ser unidimensionais e com mesma quantidade de elementos
' 2) A orientação das matrizes pode ser diferente (H x H | V x V | H x V | V x H)
'---------------------------------------------------------------------------------------
Conceitos utilizados:
1) Trabalhando com Matrizes
2) Trabalhando com Dicionários
3) Trabalhando com Suplementos
4) Desempenho
5) Limpeza de memória
6) Identação e clareza de código *
7) Documentação em XML (desnecessária para funcionar)
[/list:u:qpw4asax]
Para usar a função, é simples:
1) Abra o Excel, clique no botão no topo à esquerda, vá em Opções do Excel, Suplementos (ou Add-in)
2) Selecione Gerenciar Suplementos do Excel (ou Manage Excel Add-ins) e clique em Ir (ou Go)
3) Clique em Procurar (ou Browse), e procure o arquivo XLAM (anexado aqui no tópico que você já terá salvo em algum lugar)
4) Clique Ok e retorne ao Excel.
5) Pronto, agora a função PROC2() está disponível para sempre no seu Excel. Comece a usar.
[/list:u:qpw4asax]
Outra forma, mais fácil porém não definitiva, de usar a função é:
Option Explicit
Public Function PROC2(ByVal OQUE As Variant, _
ByRef MATRIZ_BUSCA As Excel.Range, _
ByRef MATRIZ_RESULTADO As Excel.Range, _
Optional ByVal QUAL_ITEM As Long = 1) As Variant
Application.Volatile False
On Error GoTo TratarErro
Dim rngUR As Excel.Range
Dim dicBusca As Scripting.Dictionary
Dim mtzBusca As Variant
Dim mtzResult As Variant
Dim Resultado As Variant
Dim qtdBusca As Long
Dim qtdResult As Long
Dim Contador As Long
Dim qtsAchou As Long
Dim LinsBucas As Long, ColsBusca As Long
Dim LinsResult As Long, ColsResult As Long
If ValidarIntervalo(MATRIZ_BUSCA, qtdBusca, LinsBucas, ColsBusca) And _
ValidarIntervalo(MATRIZ_RESULTADO, qtdResult, LinsResult, ColsResult) Then
If qtdBusca <> qtdResult Then
Resultado = VBA.CVErr(xlErrRef)
GoTo Finalizar
End If
Set rngUR = PegarUsedRange(MATRIZ_BUSCA.Parent)
With Application
If ColsBusca = 1 Then
mtzBusca = PegarLista(.Intersect(rngUR, MATRIZ_BUSCA))
ElseIf LinsBucas = 1 Then
mtzBusca = Transpor(PegarLista(.Intersect(rngUR, MATRIZ_BUSCA)))
End If
If ColsResult = 1 Then
mtzResult = PegarLista(.Intersect(rngUR, MATRIZ_RESULTADO))
ElseIf LinsResult = 1 Then
mtzResult = Transpor(PegarLista(.Intersect(rngUR, MATRIZ_RESULTADO)))
End If
End With
If VBA.IsArray(mtzBusca) And VBA.IsArray(mtzResult) Then
Set dicBusca = PegaDicionarioRange(Application.Intersect(rngUR, MATRIZ_BUSCA))
OQUE = VBA.UCase(OQUE)
If Not dicBusca.Exists(OQUE) Then
Resultado = VBA.CVErr(xlErrNA)
GoTo Finalizar
End If
qtsAchou = 0
For Contador = 1 To UBound(mtzBusca, 1) Step 1
If VBA.UCase(mtzBusca(Contador, 1)) = VBA.UCase(OQUE) Then
qtsAchou = qtsAchou + 1
If qtsAchou = QUAL_ITEM Then
Resultado = mtzResult(Contador, 1)
GoTo Finalizar
End If
End If
Next Contador
If qtsAchou < QUAL_ITEM Then
Resultado = VBA.CVErr(xlErrNA)
End If
End If
Else
Resultado = VBA.CVErr(xlErrRef)
End If
Finalizar:
PROC2 = Resultado
Call RemoverObjetosDaMemoria(rngUR, dicBusca, mtzBusca, mtzResult)
On Error GoTo 0
Exit Function
TratarErro:
End Function
Private Function PegaDicionarioRange(ByVal rngDados As Excel.Range) As Scripting.Dictionary
On Error GoTo TratarErro
Dim arrAux As Variant
Dim dicAux As New Scripting.Dictionary
Dim lngContador1 As Long
Dim lngContador2 As Long
If Not rngDados.Rows.Count = 0 Then
arrAux = PegarLista(rngDados)
For lngContador1 = 1 To UBound(arrAux, 1) Step 1
For lngContador2 = 1 To UBound(arrAux, 2) Step 1
If dicAux.Count = 0 Then
Call dicAux.Add(VBA.UCase(arrAux(lngContador1, lngContador2)), lngContador1)
ElseIf Not dicAux.Exists(VBA.UCase(arrAux(lngContador1, lngContador2))) Then
Call dicAux.Add(VBA.UCase(arrAux(lngContador1, lngContador2)), lngContador1)
End If
Next lngContador2
Next lngContador1
Set PegaDicionarioRange = dicAux
Else
Set PegaDicionarioRange = Nothing
End If
Call RemoverObjetosDaMemoria(dicAux, arrAux)
Exit Function
TratarErro:
End Function
'---------------------------------------------------------------------------------------
' Rotina....: PegarLista() / Function
' Contato...: fernando.reis@mondial.com.br
' Empresa...: Mondial Tecnologia em Informática LTDA.
' Descrição.: Rotina para forçar um retorno tipo array, para ranges com uma célula só
'---------------------------------------------------------------------------------------
Private Function PegarLista(ByRef rng As Range) As Variant
On Error GoTo TratarErro
Dim arrArray(1 To 1, 1 To 1) As Variant
If rng.Cells.Count = 1 Then
arrArray(1, 1) = rng.Value
PegarLista = arrArray
Else
PegarLista = rng.Value
End If
Exit Function
TratarErro:
End Function
'---------------------------------------------------------------------------------------
' Rotina....: PegarUsedRange() / Function
' Contato...: jefferson.dantas@mondial.com.br
' Empresa...: Mondial Tecnologia em Informática LTDA.
' Descrição.: Rotina que retorna o usedrange real da planilha
'---------------------------------------------------------------------------------------
Private Function PegarUsedRange(ByRef sht As Excel.Worksheet) As Excel.Range
On Error GoTo TratarErro
Dim rngAux As Excel.Range
Dim ValorAux As Long
Dim LeituraLinha As Long
Dim LeituraColuna As Long
Dim ContLinhas As Long
Dim ContColunas As Long
Dim MaxLinha As Long
Dim MaxColuna As Long
With sht
LeituraLinha = IIf(.UsedRange.Rows.Count + 10 >= .Rows.Count, .UsedRange.Rows.Count, .UsedRange.Rows.Count + 10)
LeituraColuna = IIf(.UsedRange.Columns.Count + 10 >= .Columns.Count, .UsedRange.Columns.Count, .UsedRange.Columns.Count + 10)
ValorAux = 0
For ContLinhas = 1 To .UsedRange.Rows.Count Step 1
ValorAux = .Cells(ContLinhas, LeituraColuna).End(xlToLeft).Column
If ValorAux > MaxColuna Then MaxColuna = ValorAux
Next ContLinhas
ValorAux = 0
For ContColunas = 1 To .UsedRange.Columns.Count Step 1
ValorAux = .Cells(LeituraLinha, ContColunas).End(xlUp).Row
If ValorAux > MaxLinha Then MaxLinha = ValorAux
Next ContColunas
If MaxLinha = 1 And MaxColuna = 1 Then
Set rngAux = .Cells(1, 1)
Else
Set rngAux = .Range(.Cells(1, 1), .Cells(MaxLinha, MaxColuna))
End If
Set PegarUsedRange = rngAux
End With
Call RemoverObjetosDaMemoria(rngAux)
Exit Function
TratarErro:
End Function
'---------------------------------------------------------------------------------------
' Rotina : RemoverObjetosDaMemoria() / Sub
' Contato : Fernando.Reis@mondial.com.br
' Empresa : Mondial Tecnologia em Informática
' Proposta : Rotina para remover os objetos da memoria
'---------------------------------------------------------------------------------------
Private Sub RemoverObjetosDaMemoria(ParamArray Objetos() As Variant)
On Error Resume Next 'Resume next necessario em caso de erro
Dim Contador As Integer
For Contador = 0 To UBound(Objetos) Step 1
Select Case TypeName(Objetos(Contador))
Case "Boolean"
Objetos(Contador) = False
Case "Variant", "Variant()"
If IsArray(Objetos(Contador)) Then Erase Objetos(Contador)
Objetos(Contador) = Empty
Case "String"
Objetos(Contador) = vbNullString
Case Else
Set Objetos(Contador) = Nothing
End Select
Next Contador
End Sub
'---------------------------------------------------------------------------------------
' Rotina : ValidarIntervalo() / Function
' Contato : Fernando.Reis@mondial.com.br
' Empresa : Mondial Tecnologia em Informática
' Proposta : Rotina para validar se um intervalo é unidimensional e devolver qtd de linhas e colunas
'---------------------------------------------------------------------------------------
Private Function ValidarIntervalo(ByRef rng As Excel.Range, _
ByRef QtdItens As Long, _
ByRef Lins As Long, _
ByRef Cols As Long) As Boolean
On Error GoTo TratarErro
ValidarIntervalo = True
With rng
Lins = .Rows.Count
Cols = .Columns.Count
If Lins <> 1 And Cols <> 1 Then
ValidarIntervalo = False
Exit Function
End If
If Lins <> 1 Then
QtdItens = Lins
ElseIf Cols <> 1 Then
QtdItens = Cols
End If
End With
On Error GoTo 0
Exit Function
TratarErro:
ValidarIntervalo = False
End Function
'---------------------------------------------------------------------------------------
' Rotina....: Transpor() / Function
' Contato...: Fernando.Reis@mondial.com.br
' Empresa...: Mondial Tecnologia em Informática LTDA.
' Descrição.: Rotina para transpor uma matriz bidimensional
'---------------------------------------------------------------------------------------
Public Function Transpor(ByVal arrTranspose As Variant) As Variant
On Error GoTo TratarErro
On Error GoTo TratarErro
Dim lngContador As Long
Dim lngContador1 As Long
Dim arrAux As Variant
If VBA.IsArray(arrTranspose) Then
ReDim arrAux(LBound(arrTranspose, 2) To UBound(arrTranspose, 2), LBound(arrTranspose, 1) To UBound(arrTranspose, 1))
For lngContador = 1 To UBound(arrTranspose, 2) Step 1
For lngContador1 = 1 To UBound(arrTranspose, 1) Step 1
arrAux(lngContador, lngContador1) = arrTranspose(lngContador1, lngContador)
Next lngContador1
Next lngContador
End If
Transpor = arrAux
Exit Function
TratarErro:
End Function
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 20/07/2013 2:21 pm