Finding Duplicate Entries - Saving Worksheet if none found

[PVANS]

Hi there

Hope someone can help me with this. I currently have the following code
that searches column for duplicate entries and highlights them:

Sub FindDuplicate()
On Error GoTo Merr
Dim kr As String
ColNameIn = "C"
If Len(ColNameIn) = 0 Then Exit Sub
Range(ColNameIn & 1).Activate
For A = 1 To 200
Range(ColNameIn & A).Activate
If ActiveCell.Value = kr Then
ActiveCell.Font.Bold = True
Selection.Interior.ColorIndex = 6
MsgBox "There are duplicate trade references. Please discuss with
Business Support"
Else
End If
If Len(ActiveCell.Value) = 0 Then
MsgBox "Finished Data Check", vbOKOnly + vbInformation, "Reporting"
Exit Sub
End If
kr = ActiveCell.Value
Next A
Exit Sub
Merr:
MsgBox Err.Description
End Sub

It works perfectly. However, what I need to happen, is, if no duplicate
records are found, for the following code to be invoked:
Worksheets("Cleaned Results").Copy
Set wb = ActiveWorkbook
wb.SaveAs "C:\New Report" & Month(Range("F2").Value) &
Day(Range("F2").Value) & Year(Range("F2").Value) & ".csv"
wb.Close

If duplicate records are found, I want the sub to end so that the user can
fix these issues.

Would be so grateful for some help with this.

Thanks

Paul

 

[Dave Peterson]

Maybe...

Option Explicit
Sub FindDuplicate()
Dim kr As String
Dim ColNameIn As String
Dim A As Long
Dim FoundADuplicate As Boolean

On Error GoTo Merr

FoundADuplicate = False
ColNameIn = "C"
If Len(ColNameIn) = 0 Then
Exit Sub
End If
Range(ColNameIn & 1).Activate
For A = 1 To 200
Range(ColNameIn & A).Activate
If ActiveCell.Value = kr Then
ActiveCell.Font.Bold = True
Selection.Interior.ColorIndex = 6
FoundADuplicate = True
'if you want to stop looking after the first
'duplicate, then uncomment the next line
'exit for
End If
If Len(ActiveCell.Value) = 0 Then
MsgBox "Finished Data Check", vbOKOnly + vbInformation, _
"Reporting"
Exit For
End If
kr = ActiveCell.Value
Next A

If FoundADuplicate = True Then
'just a single message instead of a message
'for each duplicate
MsgBox "There are duplicate trade references." _
& vbLf & "Please discuss with Business Support"
Else
Worksheets("Cleaned Results").Copy
Set wb = ActiveWorkbook
wb.SaveAs "C:\New Report" _
& Month(Range("F2").Value) _
& Day(Range("F2").Value) _
& Year(Range("F2").Value) & ".csv"
wb.Close
End If

Exit Sub

Merr:
MsgBox Err.Description

End Sub

But your code only looks for consecutive duplicates, right?

 

[PVANS]

Dave, thanks for the assistance - the way you modified the code seems to have
done the trick... although, I didnt realise it only looked for consecutive
duplicates . Is there a way we can further modify it so that it looks
through the entire worksheet for duplicates in that column?

Thanks for pointing that out, I didnt realise at all!

Thanks for the earlier help too.

 

[Dave Peterson]

This may work ok. I did change the logic so check to see if it still does what
you want.

Option Explicit
Sub FindDuplicate2()
Dim myCell As Range
Dim myRng As Range
Dim wks As Worksheet
Dim HowMany As Long
Dim HowManyDuplicateCells As Long
Dim resp As Long
Dim NewSheet As Worksheet
Dim myFileName As String

Set wks = Nothing
On Error Resume Next
Set wks = Worksheets("Cleaned Results")
On Error GoTo 0

If wks Is Nothing Then
MsgBox "The ""Cleaned Results"" worksheet" _
& " isn't in the activeworkbook." _
& vbLf _
& "Please activate the correct workbook and retry."
Exit Sub
End If

With wks
Set myRng = .Range("C1", .Cells(.Rows.Count, "C").End(xlUp))
End With

With myRng
'start afresh
.Interior.ColorIndex = xlNone
.Font.Bold = False
End With

HowManyDuplicateCells = 0
For Each myCell In myRng.Cells
With myCell
HowMany = Application.CountIf(myRng, .Value)
If HowMany > 1 Then 'don't count itself
HowManyDuplicateCells = HowManyDuplicateCells + 1
.Interior.ColorIndex = 6
.Font.Bold = True
End If
End With
Next myCell

If HowManyDuplicateCells = 0 Then
'perfect!
resp = MsgBox _
(prompt:="Finished Data Check" _
& vbLf & vbLf _
& "Do you want to save the sheet as a new workbook", _
Buttons:=vbYesNo)

If resp = vbNo Then
MsgBox "Ok. Try later"
Else
wks.Copy 'to a new workbook
Set NewSheet = ActiveSheet

With NewSheet
myFileName = "C:\New Report" _
& Format(.Range("F2").Value, "yyyymmdd") _
& ".csv"
On Error Resume Next
'overwrite any existing file automatically!
Application.DisplayAlerts = False
.Parent.SaveAs Filename:=myFileName, FileFormat:=xlCSV
If Err.Number <> 0 Then
Err.Clear
MsgBox "Save as CSV file failed!" _
& vbLf & "Please save manually!"
Else
.Parent.Close savechanges:=False
MsgBox "Saved as: " & myFileName
End If
Application.DisplayAlerts = True
On Error GoTo 0
End With
End If
Else
'not quite perfect
MsgBox "There are " & HowManyDuplicateCells _
& " cells with duplicate trade references." _
& vbLf & "Please discuss with Business Support"
End If

End Sub


I also changed the name of the CSV file. I find it easier to sort by name and
see the dates in nice order (year, month, day).