Philcjr
08-26-2008, 09:31 AM
Can someone take a look at my coding and help me figure out why the Special Cells "Count" is not working... between the commented lines. Oh ya, if there are any other areas in my coding that needs to be tweaked just let me know. Thanks in advance.
Option Explicit
Sub HighlightDups()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim tmpws As Worksheet: Set tmpws = ThisWorkbook.Sheets.Add
Dim rngFilter As Range, rngUnique As Range, C As Range, rngWhole As Range
Dim lngRows As Long, I As Long, LastRow As Long
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
If ws.AutoFilterMode Then ws.Cells.AutoFilter 'Check for AutoFilter
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Find last row
Set rngFilter = ws.Range("I1:I" & LastRow) 'Column for unique records
rngFilter.AdvancedFilter xlFilterCopy, , tmpws.Cells(1, 1), True 'Get the unique records
Set rngUnique = tmpws.Range("A2", tmpws.Cells(tmpws.Rows.Count, "A").End(xlUp)) 'Set the range for unique records
Set rngWhole = ws.Range("A1:X" & LastRow) 'Define entire range from sheet1
For Each C In rngUnique
rngWhole.AutoFilter 9, C.Value 'Filter on unique record # from col I
'========================================================================== ==============================
lngRows = Application.WorksheetFunction.Count(ws.Range("I:I").SpecialCells(xlCellTypeVisible))
'========================================================================== ==============================
If lngRows < 2 Then GoTo Skip
With ws.Range("A2:X" & LastRow).SpecialCells(xlCellTypeVisible)
.Interior.ColorIndex = 6 'Yellow
.Font.Bold = True
End With
Skip:
Next C
ws.Cells.AutoFilter 'Turn off AutoFilter
ws.Activate 'Active sheet1
tmpws.Delete 'Delete temp worksheet
Set rngWhole = Nothing: Set rngUnique = Nothing: Set rngFilter = Nothing: Set ws = Nothing
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Option Explicit
Sub HighlightDups()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim tmpws As Worksheet: Set tmpws = ThisWorkbook.Sheets.Add
Dim rngFilter As Range, rngUnique As Range, C As Range, rngWhole As Range
Dim lngRows As Long, I As Long, LastRow As Long
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
If ws.AutoFilterMode Then ws.Cells.AutoFilter 'Check for AutoFilter
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'Find last row
Set rngFilter = ws.Range("I1:I" & LastRow) 'Column for unique records
rngFilter.AdvancedFilter xlFilterCopy, , tmpws.Cells(1, 1), True 'Get the unique records
Set rngUnique = tmpws.Range("A2", tmpws.Cells(tmpws.Rows.Count, "A").End(xlUp)) 'Set the range for unique records
Set rngWhole = ws.Range("A1:X" & LastRow) 'Define entire range from sheet1
For Each C In rngUnique
rngWhole.AutoFilter 9, C.Value 'Filter on unique record # from col I
'========================================================================== ==============================
lngRows = Application.WorksheetFunction.Count(ws.Range("I:I").SpecialCells(xlCellTypeVisible))
'========================================================================== ==============================
If lngRows < 2 Then GoTo Skip
With ws.Range("A2:X" & LastRow).SpecialCells(xlCellTypeVisible)
.Interior.ColorIndex = 6 'Yellow
.Font.Bold = True
End With
Skip:
Next C
ws.Cells.AutoFilter 'Turn off AutoFilter
ws.Activate 'Active sheet1
tmpws.Delete 'Delete temp worksheet
Set rngWhole = Nothing: Set rngUnique = Nothing: Set rngFilter = Nothing: Set ws = Nothing
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub