Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Finding Duplicate Entries - Saving Worksheet if none found
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Finding Duplicate Entries - Saving Worksheet if none found
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 wrote: 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Finding Duplicate Entries - Saving Worksheet if none found
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" wrote: 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 wrote: 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 . |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Finding Duplicate Entries - Saving Worksheet if none found
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). PVANS wrote: 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" wrote: 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 wrote: 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 . -- Dave Peterson |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Finding Duplicate Entries | Excel Worksheet Functions | |||
Finding duplicate entries | Excel Worksheet Functions | |||
Finding Duplicate Entries | Excel Discussion (Misc queries) | |||
Need help with finding duplicate entries | Excel Worksheet Functions | |||
finding duplicate entries | Excel Programming |