✔ Programação GLOBAL®: janeiro 2009

MS Excel - Deletando linhas - 07 – Linhas duplicadas - Delete duplicate rows

Olá novamente... Vez por outra colamos bases de dados no MS Excel para análise e sem que nos apercebamos dados duplicados acabam ficando juntos em nosso range.

Como efetuar uma depuração que retire as ocorrências duplicadas deixando somente uma versão de cada registro?

Pois bem, a solução abaixo é o resultado de tal necessidade. Implementem, deixem o crédito para quem desenvolveu e tudo estará bem.

Public Sub DelDupliRows (rng As Range)

' Author: Date: Contact:

' André Bernardes 29/01/2009 12:18 bernardess@gmail.com

' Esta SUB deletará registros (linhas) duplicadas, será baseada no Range passado

' como parâmetro. Quando esta SUB achar mais duma ocorrência no mesmo Range,

' todas as ocorrências seguintes serão deletadas.

Dim r As Long

Dim n As Long

Dim v As Variant

On Error GoTo EndMacro

Let Application.ScreenUpdating = False

Let Application.Calculation = xlCalculationManual

Let Application.StatusBar = "Linha sendo processada: " & _
Format(rng.Row, "#,##0")

Let n = 0

For r = rng.Rows.Count To 2 Step -1

If r Mod 500 = 0 Then

Let Application.StatusBar = "Processing Row: " & Format(r, "#,##0")

End If

Let v = rng.Cells(r, 1).Value

If v = vbNullString Then

If Application.WorksheetFunction.CountIf(rng.Columns(1), vbNullString) > 1 Then

rng.Rows(r).EntireRow.Delete

Let n = n + 1

End If

Else

If Application.WorksheetFunction.CountIf(rng.Columns(1), v) > 1 Then

rng.Rows(r).EntireRow.Delete

Let n = n + 1

End If

Next r

EndMacro:

Let Application.StatusBar = False

Let Application.ScreenUpdating = True

Let Application.Calculation = xlCalculationAutomatic

MsgBox CStr(n) & "Linha(s) Duplicada(s) Deleta(s) "

End Sub

Tags: Excel, Column, Coluna, Delete, Linha, Plan, Planilhas, Report, Row, rows,worksheet, lines, duplicate, duplicado, dados, paste, cut

André Luiz Bernardes

A&A® - In Any Place.

MS Excel – Máscara para CNPJ

| Blog Office VBA | Blog Excel | Blog Access |

100.000 VISITAS

Como sabem, sempre precisamos nos lembrar dos campos tão tipicamente brasileiros para o preenchimento de cadastros.

O CNPJ não foge a regra, sempre necessitamos preparar o campo que receberá o seu conteúdo.

Abaixo uma pequena SUB que força o preenchimento de acordo com a máscara desejada.

Function CNPJFormat() as String

Let CNPJFormat = Format([Campo], "00"".""000"".""000""/""0000""-""00")

End Sub

Futuramente disponibilizo o modo de check quanto aos cálculos do mesmo, isso sim, muito mais interessantes.

Tags: VBA, Excel, CNPJ, format, máscara,

MS Excel – Deletando linhas - 05

Termo de Responsabilidade

Desenvolvi esta solução a partir de várias soluções que poderão consultar depois.

A solução abaixo checa as linhas abaixo da linha 11 (o que poderá customizar), deletando quando encontra a linha totalmente em branco, bem como quando a coluna "C" estiver vazia.

Sub PreparePlan_DelAllBlankRows()

' Author: Date: Contact:

' André Bernardes 23/01/2009 10:17 bernardess@gmail.com

Dim i As Long ' We use Long in case they have over 32.767 rows selected.

With Application

.Calculation = xlCalculationManual

.ScreenUpdating = False

For i = 11 To ActiveSheet.UsedRange.Rows.Count

If Range("C" & i).Value = "" Then 'WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then

Rows(i).Select

Selection.Delete Shift:=xlUp

End If

Next i

.Calculation = xlCalculationAutomatic

.ScreenUpdating = True

End With

End Sub

Outro exemplo:

Sub DeleteBlankRows1()

'Deletes the entire row within the selection if the ENTIRE row contains no data.

'We use Long in case they have over 32,767 rows selected.

Dim i As Long

'We turn off calculation and screenupdating to speed up the macro.

With Application

.Calculation = xlCalculationManual

.ScreenUpdating = False

'We work backwards because we are deleting rows.

For i = Selection.Rows.Count To 1 Step -1

If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then

Selection.Rows(i).EntireRow.Delete

End If

Next i

.Calculation = xlCalculationAutomatic

.ScreenUpdating = True

End With

End Sub

Mais um exemplo:

Sub DeleteBlankRows2()

'Deletes the entire row within the selection if some of the cells WITHIN THE SELECTION contain no data.

On Error Resume Next

Selection.EntireRow.SpecialCells(xlBlanks).EntireRow.Delete

On Error GoTo 0

End Sub

Terceiro exemplo:

Sub DeleteBlankRows3()

'Deletes the entire row within the selection if the ENTIRE row contains no data.

Dim Rw As Range

If WorksheetFunction.CountA(Selection) = 0 Then

MsgBox "No data found", vbOKOnly, "OzGrid.com"

Exit Sub

End If

With Application

.Calculation = xlCalculationManual

.ScreenUpdating = False

Selection.SpecialCells(xlCellTypeBlanks).Select

For Each Rw In Selection.Rows

If WorksheetFunction.CountA(Selection.EntireRow) = 0 Then

Selection.EntireRow.Delete

End If

Next Rw

.Calculation = xlCalculationAutomatic

.ScreenUpdating = True

End With

End Sub

Quarto exemplo:

Sub MoveBlankRowsToBottom()

'Assumes the list has a heading

With Selection

.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, _

Header:=xlYes, OrderCustom:=1, MatchCase:=False, _

Orientation:=xlTopToBottom

End With

End Sub

Sub DeleteRowsBasedOnCriteria()

'Assumes the list has a heading.

With ActiveSheet

If .AutoFilterMode = False Then .Cells(1, 1).AutoFilter

.Range("A1").AutoFilter Field:=1, Criteria1:="Delete"

.Range("A1").CurrentRegion.Offset(1, 0).SpecialCells _

(xlCellTypeVisible).EntireRow.Delete

.AutoFilterMode = False

End With

End Sub

5º exemplo:

Sub DeleteRowsWithSpecifiedData()

'Looks in Column D and requires Column IV to be clean

Columns(4).EntireColumn.Insert

With Range("D1:D" & ActiveSheet.UsedRange.Rows.Count)

.FormulaR1C1 = "=IF(RC[1]="""","""",IF(RC[1]=""Not Needed"",NA()))"

.Value = .Value

On Error Resume Next

.SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete

End With

On Error GoTo 0

Columns(4).EntireColumn.Delete