Já tive a oportunidade de disponibilizar aqui outros modos de como identificar qual é a última linha (ou o último registro) numa planilha de dados. Entre todas as técnicas de VBA, esta é uma das melhores.
Para ser breve e suscinto, as outras técnicas volta e meia eram falhas devido a dirty area.
Depois de algum tempo alguns programadores acharam a melhor técnica para identificarmos a última ocorrência sem falhas. O exemplo abaixo é uma variante da técnica ensinada pelo Excel MVP, Bob Umlas. Testem naquelas bases de dados mais parrudas, com grandes quantidades de dados, acima de 100.000 linhas e vejam o excelente resultado.
- CÓDIGO: SELECIONAR TUDO
Function LCell(ws As Worksheet) As Range
Dim LRow&, LCol%
On Error Resume Next
With ws
Let LRow& = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
Let LCol% = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
End With
Set LCell = ws.Cells(LRow&, LCol%)
End Function
Usando esta função:
A função LCell demonstrada aqui não poderá ser utilizada diretamente em uma planilha, mas poderá ser evocada a partir de outro procedimento VBA. Implemente o código como abaixo:
- CÓDIGO: SELECIONAR TUDO
Sub Identifica()
MsgBox LCell(Sheet1).Row
End Sub
Outra contribuição interessante é essa cuja a função retorna diretamente o número da última linha, inclusive para uma célula de planilha, contribuição de Adilson Soledade neste Fórum da Info, num tópico que iniciei:
- CÓDIGO: SELECIONAR TUDO
Function LRow(Ref As Range) As Integer
Dim ws As Worksheet
On Error Resume Next
Set ws = Ref.Parent
LRow = ws.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
End Function
Muitas e muitas vezes, vejo postado em diversos outros fóruns ao redor da WEB, pessoas pedindo uma macro para excluir todas as linhas em branco ou todas as linhas duplicadas de uma série de linhas em uma planilha.
Aqui tem três códigos:
Bernardes_DeleteBlankRows,
Bernardes_DeleteRowOnCell, e
Bernardes_DeleteDuplicateRows.
Lembre-se, estas macros apagam linhas inteiras de sua planilha, não excluem células individuais.
Excluindo linhas em branco
O código Bernardes_DeleteBlankRows descrito a seguir irá apagar todas as linhas em branco na planilha especificada pelaWorksheetName parâmetro. Se este parâmetro for omitido, a planilha ativa será utilizada. O procedimento apagará as linhas que estiverem totalmente em branco ou contiverem células cujo o conteúdo seja apenas um único apóstrofe (caracter que controla a formatação). O procedimento exige a função IsRowClear, mostrada após o procedimento Bernardes_DeleteBlankRows.
Não apagará as linhas que contém fórmulas, mesmo que a fórmula retorne um valor vazio. A função não excluirá as linhas precedentes de uma fórmula em uma célula se as linhas precedentes tiverem menor número de linhas que a linha. No entanto, se uma fórmula referir-se a uma série de linhas com números mais altos do que as células que contém a fórmula, e as linhas forem totalmente em branco, as linhas referenciadas pela fórmula serão excluídas. Portanto, a referência da fórmula pode ser alterada nas linhas acima da fórmula excluída.
- CÓDIGO: SELECIONAR TUDO
Sub Bernardes_DeleteBlankRows(Optional WorksheetName As Variant)
' This function will delete all blank rows on the worksheet
' named by WorksheetName. This will delete rows that are
' completely blank (every cell = vbNullString) or that have
' cells that contain only an apostrophe (special Text control
' character).
' The code will look at each cell that contains a formula,
' then look at the precedents of that formula, and will not
' delete rows that are a precedent to a formula. This will
' prevent deleting precedents of a formula where those
' precedents are in lower numbered rows than the formula
' (e.g., formula in A10 references A1:A5). If a formula
' references cell that are below (higher row number) the
' last used row (e.g, formula in A10 reference A20:A30 and
' last used row is A15), the refences in the formula will
' be changed due to the deletion of rows above the formula.
Dim RefColl As Collection
Dim RowNum As Long
Dim Prec As Range
Dim Rng As Range
Dim DeleteRange As Range
Dim LastRow As Long
Dim FormulaCells As Range
Dim Test As Long
Dim WS As Worksheet
Dim PrecCell As Range
If IsMissing(WorksheetName) = True Then
Set WS = ActiveSheet
Else
On Error Resume Next
Set WS = ActiveWorkbook.Worksheets(WorksheetName)
If Err.Number <> 0 Then
'''''''''''''''''''''''''''''''
' Invalid worksheet name.
'''''''''''''''''''''''''''''''
Exit Sub
End If
End If
If Application.WorksheetFunction.CountA(WS.UsedRange.Cells) = 0 Then
''''''''''''''''''''''''''''''
' Worksheet is blank. Get Out.
''''''''''''''''''''''''''''''
Exit Sub
End If
' Find the last used cell on the
' worksheet.
''''''''''''''''''''''''''''''''''''''
Set Rng = WS.Cells.Find(what:="*", after:=WS.Cells(WS.Rows.Count, WS.Columns.Count), lookat:=xlPart, _
searchorder:=xlByColumns, searchdirection:=xlPrevious, MatchCase:=False)
Let LastRow = Rng.Row
Set RefColl = New Collection
'''''''''''''''''''''''''''''''''''''
' We go from bottom to top to keep
' the references intact, preventing
' #REF errors.
'''''''''''''''''''''''''''''''''''''
For RowNum = LastRow To 1 Step -1
Set FormulaCells = Nothing
If Application.WorksheetFunction.CountA(WS.Rows(RowNum)) = 0 Then
''''''''''''''''''''''''''''''''''''
' There are no non-blank cells in
' row R. See if R is in the RefColl
' reference Collection. If not,
' add row R to the DeleteRange.
''''''''''''''''''''''''''''''''''''
On Error Resume Next
Test = RefColl(CStr(RowNum))
If Err.Number <> 0 Then
''''''''''''''''''''''''''
' R is not in the RefColl
' collection. Add it to
' the DeleteRange variable.
''''''''''''''''''''''''''
If DeleteRange Is Nothing Then
Set DeleteRange = WS.Rows(RowNum)
Else
Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum))
End If
Else
''''''''''''''''''''''''''
' R is in the collection.
' Do nothing.
''''''''''''''''''''''''''
End If
On Error GoTo 0
Err.Clear
Else
'''''''''''''''''''''''''''''''''''''
' CountA > 0. Find the cells
' containing formula, and for
' each cell with a formula, find
' its precedents. Add the row number
' of each precedent to the RefColl
' collection.
'''''''''''''''''''''''''''''''''''''
If IsRowClear(RowNum:=RowNum) = True Then
'''''''''''''''''''''''''''''''''
' Row contains nothing but blank
' cells or cells with only an
' apostrophe. Cells that contain
' only an apostrophe are counted
' by CountA, so we use IsRowClear
' to test for only apostrophes.
' Test if this row is in the
' RefColl collection. If it is
' not in the collection, add it
' to the DeleteRange.
'''''''''''''''''''''''''''''''''
On Error Resume Next
Test = RefColl(CStr(RowNum))
If Err.Number = 0 Then
''''''''''''''''''''''''''''''''''''''
' Row exists in RefColl. That means
' a formula is referencing this row.
' Do not delete the row.
''''''''''''''''''''''''''''''''''''''
Else
If DeleteRange Is Nothing Then
Set DeleteRange = WS.Rows(RowNum)
Else
Set DeleteRange = Application.Union(DeleteRange, WS.Rows(RowNum))
End If
End If
Else
On Error Resume Next
Set FormulaCells = Nothing
Set FormulaCells = WS.Rows(RowNum).SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If FormulaCells Is Nothing Then
'''''''''''''''''''''''''
' No formulas found. Do
' nothing.
'''''''''''''''''''''''''
Else
'''''''''''''''''''''''''''''''''''''''''''''''''''
' Formulas found. Loop through the formula
' cells, and for each cell, find its precedents
' and add the row number of each precedent cell
' to the RefColl collection.
'''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
For Each Rng In FormulaCells.Cells
For Each Prec In Rng.Precedents.Cells
RefColl.Add Item:=Prec.Row, key:=CStr(Prec.Row)
Next Prec
Next Rng
On Error GoTo 0
End If
End If
End If
'''''''''''''''''''''''''
' Go to the next row,
' moving upwards.
'''''''''''''''''''''''''
Next RowNum
''''''''''''''''''''''''''''''''''''''''''
' If we have rows to delete, delete them.
''''''''''''''''''''''''''''''''''''''''''
If Not DeleteRange Is Nothing Then
DeleteRange.EntireRow.Delete shift:=xlShiftUp
End If
End Sub
Function IsRowClear(RowNum As Long) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''
' IsRowClear
' This procedure returns True if all the cells
' in the row specified by RowNum as empty or
' contains only a "'" character. It returns False
' if the row contains only data or formulas.
''''''''''''''''''''''''''''''''''''''''''''''''''
Dim ColNdx As Long
Dim Rng As Range
ColNdx = 1
Set Rng = Cells(RowNum, ColNdx)
Do Until ColNdx = Columns.Count
If (Rng.HasFormula = True) Or (Rng.Value <> vbNullString) Then
IsRowClear = False
Exit Function
End If
Set Rng = Cells(RowNum, ColNdx).End(xlToRight)
ColNdx = Rng.Column
Loop
Let IsRowClear = True
End Function
Este código, Bernardes_DeleteBlankRows, excluirá uma linha, se toda a linha estiver em branco. Apagará a linha inteira se uma célula na coluna especificada estiver em branco. Somente a coluna marcada, outras são ignoradas.
- CÓDIGO: SELECIONAR TUDO
Public Sub Bernardes_DeleteRowOnCell()
On Error Resume Next
Selection.SpecialCells (xlCellTypeBlanks). EntireRow.Delete
ActiveSheet.UsedRange
End Sub
Para usar este código, selecione um intervalo de células por colunas e, em seguida, execute o código. Se a célula na coluna estiver em branco, a linha inteira será excluída. Para processar toda a coluna, clique no cabeçalho da coluna para selecionar a coluna inteira.
Este código eliminará as linhas duplicadas em um intervalo. Para usar, selecione uma coluna como intervalo de células, que compreende o intervalo de linhas duplicadas a serem excluídas. Somente a coluna selecionada é usada para comparação.
- CÓDIGO: SELECIONAR TUDO
Sub Bernardes_DeleteDuplicateRows Pública ()
''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''
'DeleteDuplicateRows
"Isto irá apagar registros duplicados, com base na coluna ativa. Ou seja,
"se o mesmo valor é encontrado mais de uma vez na coluna activa, mas todos
"os primeiros (linha número mais baixo) serão excluídos.
"
'Para executar a macro, selecione a coluna inteira que você deseja escanear
'duplica e executar este procedimento.
'''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''
R Dim As Long
Dim N Long
V Variant Dim
Dim Rng Gama
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Rng = Application.Intersect (ActiveSheet.UsedRange, _
ActiveSheet.Columns (ActiveCell.Column))
Let Application.StatusBar = "Processamento de Linha:" & Format (Rng.Row , "#,## 0 ")
Let N = 0
Let R = Rng.Rows.Count To 2 Step -1
IF Mod R 500 = 0 Then
Let Application.StatusBar = "Linha de processamento:" & Format (R ", # # 0 ")
End If
? = Rng.Cells (R, 1). Valor V
'''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''
Nota "que COUNTIF obras estranhamente com uma variante que é igual a vbNullString.
" Ao invés de passar na variante, você precisa passar vbNullString explicitamente.
''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''
Let V = vbNullString Então
Let Application.WorksheetFunction. CONT.SE (Rng.Columns (1), vbNullString)> 1 Então
Rng.Rows (R). EntireRow.Delete
Let N = N + 1
End If
Else
Se Application.WorksheetFunction.CountIf (Rng.Columns (1), V)> 1 Então,
(R). Rng.Rows EntireRow.Delete
Let N = N + 1
End If
End If
Next R
EndMacro:
Let Application.StatusBar = False
Let Application.ScreenUpdating = True
Let Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicar linhas excluídas:" & CStr (N )
End Sub
Tags: VBA, excel, dirty area, column, row, linha, coluna, delete,
