Usei este código *(baseado em rotinas prontas, antigas minhas):
Option Explicit
Public Enum CellProperty
Value = 0
Formula = 1
FormulaR1C1 = 2
End Enum
Public Sub ValoresExclusivosDaMatriz()
Dim Planilha As Worksheet
Dim Intervalo As Range
Dim mtzItens As Variant
Dim dicItens As Scripting.Dictionary
'instanciando os objetos
Set Planilha = Worksheets("Planilha1")
Set Intervalo = Planilha.Range("A1:A10")
'pegando a matriz
mtzItens = GetArrayFromRange(Intervalo, Value)
'pegando o dicionário da matriz
Set dicItens = GetDictionaryFromArray(mtzItens, dicItens, xlNo, 1, False)
'pegando a matriz do dicionário
mtzItens = GetArrayFromDictionary(dicItens, "V")
'Derrubando a matriz na planilha, 1 é a linha e 2 é a coluna
Call DropArray(Planilha, 1, 2, mtzItens, False)
'limpando a memória
Call RemoveObjectsFromMemory(Planilha, Intervalo, mtzItens, dicItens)
End Sub
'---------------------------------------------------------------------------------------
' Modulo....: xlArrays / Módulo
' Rotina....: GetArrayFromRange() / Function
' Autor.....: Fernando Reis
' Contato...: fernando.fernandes@outlook.com.br
' Data......: 12/19/2012 (mdy)
' Empresa...: Planilhando
' Descrição.: This routine creates an array from a given range of 1 or more cells.
'---------------------------------------------------------------------------------------
Public Function GetArrayFromRange(ByRef rng As Range, Optional WhichProperty As CellProperty = CellProperty.Value) As Variant
On Error GoTo TreatError
Dim arrArray(1 To 1, 1 To 1) As Variant
If rng.Cells.Count = 1 Then
Select Case WhichProperty
Case CellProperty.Value
arrArray(1, 1) = rng.Value
GetArrayFromRange = arrArray
Case CellProperty.Formula
arrArray(1, 1) = rng.Formula
GetArrayFromRange = arrArray
Case CellProperty.FormulaR1C1
arrArray(1, 1) = rng.FormulaR1C1
GetArrayFromRange = arrArray
End Select
Else
Select Case WhichProperty
Case CellProperty.Value
GetArrayFromRange = rng.Value
Case CellProperty.Formula
GetArrayFromRange = rng.Formula
Case CellProperty.FormulaR1C1
GetArrayFromRange = rng.FormulaR1C1
End Select
End If
On Error GoTo 0
Exit Function
TreatError:
'Call xlExceptions.TreatError(VBA.Err.Description, VBA.Err.Number, "xlArrays.GetArrayFromRange()", Erl, True)
End Function
'---------------------------------------------------------------------------------------
' Modulo....: xlArrays / Módulo
' Rotina....: GetArrayFromDictionary() / Function
' Autor.....: Fernando Reis
' Contato...: fernando.fernandes@outlook.com.br
' Data......: 02/18/2014 (mdy)
' Empresa...: Planilhando
' Descrição.: This routine gets all the content of a range and loads it into a dictionary
'---------------------------------------------------------------------------------------
Public Function GetArrayFromDictionary(ByVal dic As Scripting.Dictionary, _
ByVal Orientation As String) As Variant
On Error GoTo TreatError
Dim key As Variant
Dim mtz As Variant
Dim cnt As Long
cnt = 1
If Not dic Is Nothing Then
If dic.Count > 0 Then
Select Case Orientation
Case "H"
ReDim mtz(1 To 1, 1 To dic.Count)
For Each key In dic
mtz(1, cnt) = key
cnt = cnt + 1
Next key
Case "V"
ReDim mtz(1 To dic.Count, 1 To 1)
For Each key In dic
mtz(cnt, 1) = key
cnt = cnt + 1
Next key
End Select
End If
End If
If VBA.IsArray(mtz) Then GetArrayFromDictionary = mtz
Call RemoveObjectsFromMemory(mtz, key, cnt)
On Error GoTo 0
Exit Function
TreatError:
''Call xlExceptions.TeatError(Err.Description, Err.Number, "xlArrays.GetArrayFromDictionary()")
End Function
'---------------------------------------------------------------------------------------
' Rotina....: ResizeArray() / Sub
' Contato...: fernando.fernandes@outlook.com.br
' Autor.....: Jefferson Dantas
' Revisão...: Fernando Fernandes
' Empresa...: Planilhando
' Descrição.: This routine transposes any bidimensional array
'---------------------------------------------------------------------------------------
Public Sub ResizeArray(ByRef mtz As Variant, ByVal NewSize As Long)
On Error GoTo TreatError
Dim FirstElementRow As Long, LastElementRow As Long
Dim FirstElementCol As Long, LastElementCol As Long
FirstElementRow = LBound(mtz, 1): FirstElementCol = LBound(mtz, 2)
LastElementRow = UBound(mtz, 1): LastElementCol = UBound(mtz, 2)
mtz = TransposeArray(mtz)
ReDim Preserve mtz(FirstElementCol To LastElementCol, FirstElementRow To NewSize)
mtz = TransposeArray(mtz)
On Error GoTo 0
Exit Sub
TreatError:
''Call xlExceptions.TeatError(VBA.Err.Description, VBA.Err.Number, "xlArrays.ResizeArray()", Erl, True)
End Sub
'---------------------------------------------------------------------------------------
' Rotina....: TransposeArray() / Function
' Contato...: fernando.fernandes@outlook.com.br
' Autor.....: Jefferson Dantas
' Revisão...: Fernando Fernandes
' Empresa...: Planilhando
' Descrição.: This routine transposes any bidimensional array
'---------------------------------------------------------------------------------------
Public Function TransposeArray(ByVal Matriz As Variant) As Variant
On Error GoTo TreatError
Dim lngContador As Long
Dim lngContador1 As Long
Dim arrAux As Variant
If VBA.IsArray(Matriz) Then
Select Case NumberOfDimensions(Matriz)
Case 1
Matriz = Matriz
Case 2
'creating auxiliary array with inverted dimensions
ReDim arrAux(LBound(Matriz, 2) To UBound(Matriz, 2), LBound(Matriz, 1) To UBound(Matriz, 1))
For lngContador = LBound(Matriz, 2) To UBound(Matriz, 2) Step 1
For lngContador1 = LBound(Matriz, 1) To UBound(Matriz, 1) Step 1
arrAux(lngContador, lngContador1) = Matriz(lngContador1, lngContador)
Next lngContador1
Next lngContador
End Select
End If
TransposeArray = arrAux
On Error GoTo 0
Exit Function
TreatError:
''Call xlExceptions.TeatError(VBA.Err.Description, VBA.Err.Number, "xlArrays.TransposeArray()", Erl, True)
End Function
'---------------------------------------------------------------------------------------
Public Function NumberOfDimensions(ByVal arr As Variant) As Long
On Error GoTo TreatError
Dim cnt As Long
cnt = 1
Do Until Err.Number <> 0
If LBound(arr, cnt) >= 0 Then NumberOfDimensions = cnt
cnt = cnt + 1
Loop
On Error GoTo 0
Exit Function
TreatError:
Exit Function
'''Call xlExceptions.TeatError(VBA.Err.Description, VBA.Err.Number, "xlArrays.NumberOfDimensions()", Erl, True)
End Function
'---------------------------------------------------------------------------------------
' Rotina......: DropArray() / Sub
' Contato.....: fernando.fernandes@outlook.com.br
' Autor.......: Fernando Fernandes
' Date........: Nov/15th/2013
' Review Date.: Oct/6th/2014
' Empresa.....: www.Planilhando.Com.Br
' Descrição...: Routine that drops a whole array into a worksheet, given the worksheet and a start range
'---------------------------------------------------------------------------------------
Public Sub DropArray(ByRef wsh As Excel.Worksheet, ByVal lRow As Long, ByVal lCol As Long, _
ByRef arr As Variant, Optional ByVal bTranspose As Boolean = False)
On Error GoTo TreatError
Dim LocalArray As Variant
If bTranspose Then
LocalArray = TransposeArray(arr)
Else
LocalArray = arr
End If
With wsh
If LBound(LocalArray, 1) = 1 And LBound(LocalArray, 2) = 1 Then
.Range(.Cells(lRow, lCol), .Cells(lRow + UBound(LocalArray, 1) - 1, lCol + UBound(LocalArray, 2) - 1)).Value = LocalArray
ElseIf LBound(arr, 1) = 0 And LBound(arr, 2) = 0 Then
.Range(.Cells(lRow, lCol), .Cells(lRow + UBound(LocalArray, 1), lCol + UBound(LocalArray, 2))).Value = LocalArray
End If
End With
On Error GoTo 0
Exit Sub
TreatError:
'Call xlExceptions.TreatError(VBA.Err.Description, VBA.Err.Number, "xlArrays.DropArray()", Erl, True)
End Sub
'---------------------------------------------------------------------------------------
' Modulo : xlApplication / Módulo
' Rotina : RemoveObjectsFromMemory() / Sub
' Autor : Jefferson Dantas (jefferdantas@gmail.com)
' Data : 07/11/2012 - 16:42
' Revisão : Fernando Fernandes (fernando.fernandes@outlook.com.br)
' Data : 07/01/2013 (mdy)
' Proposta : Remove crap from memory
'---------------------------------------------------------------------------------------
Public Sub RemoveObjectsFromMemory(ParamArray Objects() As Variant)
On Error Resume Next 'Resume next necessario em caso de erro
Dim Counter As Integer
For Counter = 0 To UBound(Objects) Step 1
Select Case TypeName(Objects(Counter))
Case "Boolean"
Objects(Counter) = False
Case "Variant"
If VBA.IsArray(Objects(Counter)) Then Erase Objects(Counter)
Objects(Counter) = Empty
Case "String"
Objects(Counter) = vbNullString
Case "Worksheet"
Set Objects(Counter) = Nothing
Case "Workbook"
Objects(Counter).Close SaveChanges:=False
Set Objects(Counter) = Nothing
Case "Database", "Recordset2", "Recordset"
Objects(Counter).Close
Set Objects(Counter) = Nothing
Case Else
Set Objects(Counter) = Nothing
'Suggestion:
If VBA.IsObject(Objects(Counter)) Then
Set Objects(Counter) = Nothing
Else
Objects(Counter) = Empty
End If
End Select
Next Counter
On Error GoTo 0
End Sub
'---------------------------------------------------------------------------------------
' Modulo....: xlArrays / Módulo
' Rotina....: GetDictionaryFromArray() / Function
' Autor.....: Fernando Reis
' Contato...: fernando.fernandes@outlook.com.br
' Data......: 02/18/2014 (mdy)
' Empresa...: www.Planilhando.com.br
' Descrição.: This routine gets all the content of an array column and loads it into a dictionary
'---------------------------------------------------------------------------------------
Public Function GetDictionaryFromArray(ByRef ArrayToFilter As Variant, _
ByRef dicOriginal As Scripting.Dictionary, _
ByVal Header As XlYesNoGuess, _
ByVal WhichField As Long, _
ByVal Append As Boolean) As Scripting.Dictionary
On Error GoTo TreatError
Dim arrAux As Variant
Dim dicAux As New Scripting.Dictionary
Dim lngContador As Long
If Append Then Set dicAux = dicOriginal
If VBA.IsArray(ArrayToFilter) Then
For lngContador = LBound(ArrayToFilter, 1) To UBound(ArrayToFilter, 1) Step 1
If Header = xlYes And lngContador = LBound(ArrayToFilter, 1) Then GoTo Proximo
If VBA.Trim(ArrayToFilter(lngContador, WhichField)) <> vbNullString And ArrayToFilter(lngContador, WhichField) <> 0 Then
If dicAux.Count = 0 Then
Call dicAux.Add(ArrayToFilter(lngContador, WhichField), lngContador)
ElseIf Not dicAux.Exists(ArrayToFilter(lngContador, WhichField)) Then
Call dicAux.Add(ArrayToFilter(lngContador, WhichField), lngContador)
End If
End If
Proximo:
Next lngContador
Set GetDictionaryFromArray = dicAux
Else
Set GetDictionaryFromArray = VBA.IIf(Append, dicAux, Nothing)
End If
Call RemoveObjectsFromMemory(dicAux, arrAux, lngContador)
On Error GoTo 0
Exit Function
TreatError:
''Call xlExceptions.TeatError(Err.Description, Err.Number, "xlDictionariesGetDictionaryFromArray()")
End Function
O que importa pra vc editar é só a parte da sub ValoresExclusivosDaMatriz. Mas vc precisa colar tudo num módulo.
Divirta-se.
arquivo modelo:
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 23/03/2016 7:25 am