Sub Dup_Finder() Dim wb As Workbook, ws As Worksheet Set wb = ActiveWorkbook Set sSheet = wb.ActiveSheet Dim sExists As Boolean sExists = WorksheetExists("Dups") If sExists = False Then With wb .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "Dups" End With End If Set dSheet = wb.Worksheets("Dups") With dSheet j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 End With Dim rcell As Range, rng As Range, urng As Range Set urng = sSheet.Application.InputBox("Select a range or a column", "Obtain Range Object", Type:=8) Set rng = sSheet.Range(Col_Letter(urng.Column) & "1:" & Col_Letter(urng.Column) & Cells(Rows.Count, urng.Column).End(xlUp).Row) For Each rcell In rng If WorksheetFunction.CountIf(rng, rcell.Value) > 1 Then 'rcell.Style = "Bad" ' Highlight Red rcell.EntireRow.Copy Destination:=dSheet.Range("A" & j) j = j + 1 End If Next rcell Dup_Cond_Form (sSheet.Range(Col_Letter(urng.Column) & "1:" & Col_Letter(urng.Column) & Cells(Rows.Count, urng.Column).End(xlUp).Row)) dSheet.Select End Sub Function Col_Letter(lngCol As Long) As String Dim vArr vArr = Split(Cells(1, lngCol).Address(True, False), "$") Col_Letter = vArr(0) End Function Function WorksheetExists(sName As String) As Boolean WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)") End Function Sub Dup_Cond_Form(rng As Range) rng.FormatConditions.AddUniqueValues rng.FormatConditions(rng.FormatConditions.Count).SetFirstPriority rng.FormatConditions(1).DupeUnique = xlDuplicate With rng.FormatConditions(1).Font .Color = -16383844 .TintAndShade = 0 End With With rng.FormatConditions(1).Interior .PatternColorIndex = xlAutomatic .Color = 13551615 .TintAndShade = 0 End With rng.FormatConditions(1).StopIfTrue = False End Sub
Welcome to FreeSoftwareServers Confluence Wiki
Overview
Content Tools