Três módulos:
Planilhando
Option Explicit
Public Sub ExcluirLinhas()
'declaração de objetos
Dim WSF As Excel.WorksheetFunction
Dim Planilha As Worksheet
Dim Intervalo As Range
'declaração de variáveis
Dim Matriz As Variant
Dim cntLins As Long
Dim cntCols As Long
Dim Vazias As Long
Set WSF = Excel.WorksheetFunction
Set Planilha = ThisWorkbook.Worksheets("Plan1")
Set Intervalo = Planilha.UsedRange
Matriz = GetArrayFromRange(Intervalo, Value)
If VBA.IsArray(Matriz) Then
For cntLins = 6 To UBound(Matriz, 1)
Select Case VBA.Len(Matriz(cntLins, 3))
Case Is < 4
Matriz(cntLins, 1) = "apagar"
Case 0
If WSF.CountA(Planilha.Range("a" & cntLins).EntireRow) = 0 Then
Matriz(cntLins, 1) = "apagar"
End If
End Select
Next cntLins
Matriz = FilterArray(Matriz, Remove, xlNo, 1, "apagar")
Planilha.Cells.ClearContents
Call DropArray(Planilha, 1, 1, Matriz)
End If
Call RemoveObjectsFromMemory(Matriz, Intervalo, Planilha, WSF)
End Sub
plApplication
Option Explicit
Option Private Module
Public Sub Auto_Open()
Call AlterApplication(True)
End Sub
'---------------------------------------------------------------------------------------
' Modulo....: plApplication / Módulo
' Rotina....: AlterApplication() / Sub
' Autor.....: Jefferson
' Contato...: jefferdantas@gmail.com
' Data......: 12/25/2012 (mdy)
' Empresa...: Planilhando
' Descrição.: This routine turns on/off the application details during runtime.
' It does not change the saved status of the workbook
'---------------------------------------------------------------------------------------
Public Sub AlterApplication(ByVal Status As Boolean)
On Error GoTo TreatError
Dim blSaved As Boolean
blSaved = ThisWorkbook.Saved
With Application
With .ErrorCheckingOptions
'Do not change the code line below. The variable "Status" was intentionally not used.
If Not .InconsistentFormula = False Then .InconsistentFormula = False
End With
If Not Application.ActiveWorkbook Is Nothing Then
If Status Then
.Calculation = XlCalculation.xlCalculationAutomatic
Else
.Calculation = XlCalculation.xlCalculationManual
End If
End If
If Not .EnableEvents = Status Then .EnableEvents = Status
If Not .ScreenUpdating = Status Then .ScreenUpdating = Status
End With
With ThisWorkbook
If Not .Saved = blSaved Then .Saved = blSaved
End With
On Error GoTo 0
Exit Sub
TreatError:
' Call xlExceptions.TreatError(VBA.Err.Description, VBA.Err.Number, "plApplication.AlterApplication()", Erl, True)
End Sub
'---------------------------------------------------------------------------------------
' Modulo : plApplication / 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
plArrays
Option Explicit
Public Enum FilterArrayAction
Keep = 0
Remove = 1
End Enum
Public Enum CellProperty
Value = 0
Formula = 1
FormulaR1C1 = 2
End Enum
Public Enum Orientation
Vertical = 1
Horizontal = 2
End Enum
'---------------------------------------------------------------------------------------
' Rotina....: Transpose() / Function
' Contato...: fernando@tecnun.com.br
' Autor.....: Jefferson Dantas
' Revisão...: Fernando Fernandes
' Empresa...: Tecnun Tecnologia em Informática
' Descrição.: This routine transposes any uni or bidimensional array
'---------------------------------------------------------------------------------------
Public Function Transpose(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
Transpose = arrAux
On Error GoTo 0
Exit Function
TreatError:
'Call Excecoes.TratarErro(VBA.Err.Description, VBA.Err.Number, "auxArray.Transpose()", Erl)
End Function
'---------------------------------------------------------------------------------------
' Modulo....: auxarray / Módulo
' Rotina....: GetArrayFromRange() / Function
' Autor.....: Fernando Fernandes
' 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 Object, _
Optional WhichProperty As CellProperty = CellProperty.Value, _
Optional WhichRow As Long = 0) As Variant
On Error GoTo TreatError
Dim arrArray(1 To 1, 1 To 1) As Variant
With rng
If .Cells.Count = 1 Then
Select Case WhichProperty
Case CellProperty.Value
arrArray(1, 1) = .Value
GetArrayFromRange = arrArray
Case CellProperty.Formula
arrArray(1, 1) = .Formula
GetArrayFromRange = arrArray
Case CellProperty.FormulaR1C1
arrArray(1, 1) = .FormulaR1C1
GetArrayFromRange = arrArray
End Select
Else
If WhichRow = 0 Then
Select Case WhichProperty
Case CellProperty.Value
GetArrayFromRange = .Value
Case CellProperty.Formula
GetArrayFromRange = .Formula
Case CellProperty.FormulaR1C1
GetArrayFromRange = .FormulaR1C1
End Select
Else
With .Rows(WhichRow)
Select Case WhichProperty
Case CellProperty.Value
GetArrayFromRange = .Value
Case CellProperty.Formula
GetArrayFromRange = .Formula
Case CellProperty.FormulaR1C1
GetArrayFromRange = .FormulaR1C1
End Select
End With
End If
End If
End With
On Error GoTo 0
Exit Function
TreatError:
'Call Excecoes.TratarErro(VBA.Err.Description, VBA.Err.Number, "auxArray.GetArrayFromRange()", Erl)
End Function
'---------------------------------------------------------------------------------------
' Rotina....: FilterArray() / Function
' Contato...: fernando.fernandes@outlook.com.br
' Autor.....: Fernando Fernandes
' Empresa...: Planilhando
' Descrição.: This routine filters the content of any bidimensional array, with the given criterias
' arrOriginal is the complete array
' FilterAction (enum):
' Keep => Creates a brand new array, keeping only the chosen criterias in the chosen field
' Remove => Creates a brand new array, removing the chosen criterias from the chosen field
' Header determines if the array has or has not headers, to decide if the first row will be removed or not
' lColumn is the column number within the array, the field where the filter will be based on
'---------------------------------------------------------------------------------------
Public Function FilterArray(ByVal arrOriginal As Variant, _
ByVal FilterAction As FilterArrayAction, _
ByVal Header As XlYesNoGuess, _
ByVal lColumn As Long, _
ParamArray Criterias() As Variant) As Variant
On Error GoTo TreatError
Dim arrFinal As Variant
Dim cntOriginalArray As Long
Dim cntFinalArray As Long
Dim cntCriterias As Long
If VBA.IsArray(arrOriginal) Then
If lColumn <= UBound(arrOriginal, 2) Then
cntFinalArray = LBound(arrOriginal, 1)
'creating auxiliary array with same dimensions
ReDim arrFinal(LBound(arrOriginal, 1) To UBound(arrOriginal, 1), LBound(arrOriginal, 2) To UBound(arrOriginal, 2))
If Header = xlYes Then
Call CopyArrayRow(arrOriginal, LBound(arrOriginal, 1), arrFinal, LBound(arrFinal, 1))
cntFinalArray = cntFinalArray + 1
End If
For cntOriginalArray = cntFinalArray To UBound(arrOriginal, 1) Step 1
For cntCriterias = LBound(Criterias, 1) To UBound(Criterias, 1) Step 1
If (FilterAction = Keep And arrOriginal(cntOriginalArray, lColumn) Like Criterias(cntCriterias)) Or _
(FilterAction = Remove And Not arrOriginal(cntOriginalArray, lColumn) Like Criterias(cntCriterias)) Then
Call CopyArrayRow(arrOriginal, cntOriginalArray, arrFinal, cntFinalArray)
cntFinalArray = cntFinalArray + 1
End If
Next cntCriterias
Next cntOriginalArray
cntFinalArray = cntFinalArray - 1
If cntFinalArray >= 0 Then Call ResizeArray(arrFinal, cntFinalArray)
End If
End If
FilterArray = arrFinal
On Error GoTo 0
Exit Function
TreatError:
'Call Excecoes.TratarErro(VBA.Err.Description, VBA.Err.Number, "auxArray.FilterArray()", Erl, True)
End Function
'---------------------------------------------------------------------------------------
' Rotina......: DropArray() / Sub
' Contato.....: fernando.fernandes@outlook.com.br
' Autor.......: Fernando Fernandes
' Date........: Nov/15th/2013 - Original Drop Array for usual Excel arrays, starting with index 1
' Review Date.: Oct/6th/2014 - Adapted Drop Array for usual Access arrays, considering arrays starting with index 0
' Review Date.: Mar/19th/2015 - Adapted Drop Array for limiting the number of rows os columns to drop from the array
' Empresa.....: www.Planilhando.Com.Br
' Descrição...: Routine that drops a part of or a whole array into a worksheet, given the worksheet and a start range (with row and column indexes
' plus optional arguments to limit the number of rows and/or colummns to drop, from the array
'---------------------------------------------------------------------------------------
Public Sub DropArray(ByRef wsh As Object, ByVal lRow As Long, ByVal lCol As Long, _
ByRef arr As Variant, _
Optional numRows As Long = 0, _
Optional numCols As Long = 0)
On Error GoTo TreatError
Dim FinalRow As Long
Dim FinalCol As Long
With wsh
If LBound(arr, 1) = 1 And LBound(arr, 2) = 1 Then
If numRows = 0 Then FinalRow = lRow + UBound(arr, 1) - 1 Else FinalRow = numRows
If numCols = 0 Then FinalCol = lCol + UBound(arr, 2) - 1 Else FinalCol = numCols
ElseIf LBound(arr, 1) = 0 And LBound(arr, 2) = 0 Then
If numRows = 0 Then FinalRow = lRow + UBound(arr, 1) Else FinalRow = lRow + numRows - 1
If numCols = 0 Then FinalCol = lCol + UBound(arr, 2) Else FinalCol = lCol + numCols - 1
End If
.Range(.Cells(lRow, lCol), .Cells(FinalRow, FinalCol)).Value = arr
End With
On Error GoTo 0
Exit Sub
TreatError:
'Call Excecoes.TratarErro(VBA.Err.Description, VBA.Err.Number, "auxArray.DropArray()", Erl, True)
End Sub
'---------------------------------------------------------------------------------------
' Rotina......: NumberOfDimensions() / Sub
' Contato.....: fernando.fernandes@outlook.com.br
' Autor.......: Fernando Fernandes
' Date........: Feb/18th/2020
' Observação..: Eu sei é futuro, mas uma rotina que fala de dimensões, tinha que falar de viagem no tempo
' Empresa.....: www.Planilhando.Com.Br
' Descrição...: Retorna o número total de dimensões de uma matriz
'---------------------------------------------------------------------------------------
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 Excecoes.TratarErro(VBA.Err.Description, VBA.Err.Number, "AuxArray.NumberOfDimensions()", Erl, True)
End Function
'---------------------------------------------------------------------------------------
' Rotina....: ResizeArray() / Sub
' Contato...: fernando.fernandes@outlook.com.br
' Autor.....: Jefferson Dantas
' Revisão...: Fernando Fernandes
' Empresa...: Planilhando
' Descrição.: This routine resizes any bidimensional array, to a new number of rows, keeping the contents
' Redim Preserve
'---------------------------------------------------------------------------------------
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 = Transpose(mtz)
ReDim Preserve mtz(FirstElementCol To LastElementCol, FirstElementRow To NewSize)
mtz = Transpose(mtz)
On Error GoTo 0
Exit Sub
TreatError:
'Call Excecoes.TratarErro(VBA.Err.Description, VBA.Err.Number, "auxArray.ResizeArray()", Erl, True)
End Sub
'---------------------------------------------------------------------------------------
' Rotina....: SumArrays() / Sub
' Contato...: Fernando.Fernandes@Outlook.com.br
' Autor.....: Fernando Fernandes
' Ad........: www.Planilhando.Com.Br
' Date......: 06/24/2014
' Descr.....: Routine that will sum array 1 with array 2. Both have to be the same dimensions
'---------------------------------------------------------------------------------------
Public Function SumArrays(ByVal arr1 As Variant, ByVal arr2 As Variant, _
Optional ByVal Orientation As Orientation = Vertical) As Variant
On Error GoTo TreatError
Dim lRow As Long
Dim lCol As Long
If VBA.IsArray(arr1) And VBA.IsArray(arr2) Then
If UBound(arr1, 1) = UBound(arr2, 1) And UBound(arr1, 2) = UBound(arr2, 2) Then
Select Case Orientation
Case Horizontal
For lCol = LBound(arr1, 2) To UBound(arr1, 2)
arr1(1, lCol) = arr1(1, lCol) + arr2(1, lCol)
Next lCol
Case Vertical
For lRow = LBound(arr1, 1) To UBound(arr1, 1)
arr1(lRow, 1) = VBA.IIf(Not VBA.IsNumeric(arr1(lRow, 1)), 0, arr1(lRow, 1)) + VBA.IIf(Not VBA.IsNumeric(arr2(lRow, 1)), 0, arr2(lRow, 1))
Next lRow
End Select
SumArrays = arr1
End If
End If
On Error GoTo 0
Exit Function
TreatError:
'Call Excecoes.TratarErro(VBA.Err.Description, VBA.Err.Number, "auxArray.SumArrays()", Erl, True)
End Function
'---------------------------------------------------------------------------------------
' Rotina....: CopyArrayRow() / Sub
' Contato...: Fernando.Fernandes@Outlook.com.br
' Autor.....: Fernando Fernandes
' Ad........: www.Planilhando.Com.Br
' Date......: 07/28/2014
' Descr.....: Creates a replica of a row from one array in a row in another array
'---------------------------------------------------------------------------------------
Public Sub CopyArrayRow(ByRef arrFrom As Variant, _
ByVal rowFrom As Long, _
ByRef arrTo As Variant, _
ByRef rowTo As Long)
On Error GoTo TreatError
Dim cnt As Long
Dim cntFrom As Long
Dim cntTo As Long
Select Case NumberOfDimensions(arrFrom)
Case 1
If UBound(arrFrom, 1) - LBound(arrFrom, 1) = UBound(arrTo, 2) - LBound(arrTo, 2) Then
cntFrom = LBound(arrFrom, 1)
cntTo = LBound(arrTo, 2)
For cnt = LBound(arrFrom, 1) To UBound(arrFrom, 1) Step 1
arrTo(rowTo, cntTo) = arrFrom(cntFrom)
cntFrom = cntFrom + 1
cntTo = cntTo + 1
Next cnt
End If
Case 2
If UBound(arrFrom, 2) - LBound(arrFrom, 2) = UBound(arrTo, 2) - LBound(arrTo, 2) Then
cntFrom = LBound(arrFrom, 1)
cntTo = LBound(arrTo, 2)
For cnt = LBound(arrFrom, 2) To UBound(arrFrom, 2) Step 1
arrTo(rowTo, cntTo) = arrFrom(rowFrom, cntFrom)
cntFrom = cntFrom + 1
cntTo = cntTo + 1
Next cnt
End If
End Select
On Error GoTo 0
Exit Sub
TreatError:
'Call Excecoes.TratarErro(VBA.Err.Description, VBA.Err.Number, "auxArray.CopyArrayRow()", Erl, True)
End Sub
Funciona na velocidade da luz....
Segue o anexo. Qualquer dúvida, dá um grito!
FF
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel