Anybody bored

[dmtcrainey]

I don't have access to excel right now but am trying to help out a friend

go though list of 60,000 records

colum B is sorted text fields

need to find duplicate entries.

when I find an duplicate need to delete one of them ( the entire row) and column b's entry into a text file. this text file may or may not exist but at the end it will contain all of the duplicates.

any help would be appreciatted. if not I will take the time to do this later.

 

[Everett99]

Use the "Tools, Macro, Record New Macro" function to record these steps.

In column C (you said your data was in column B, and sorted) enter this formula beginning in cell C2 (I assume you have column headers):

=if(b2=b1,1,0)

Copy this formula to the bottom of your data.
Convert the formulas to Values
Turn on the filter (data, filter, auto filter) on the header row
Filter on column C, for any values of "1" (the duplicates).
Hide row 1 (header row)
Select the entire worksheet
Select visible cells only
Delete the visible rows
Turn off the auto filter (data, filter, auto filter)
Delete column C (don't need it anymore)
Sort the data in column B again.

 

[chiello]

Try the following code.
Remember to set correctly the following variables (as explained in the code):
StrDataRange
StrAuxDataRange

Code:

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> DelDuplicate()
<SPAN style="color:#007F00">'</SPAN>

<SPAN style="color:#007F00">'</SPAN>
<SPAN style="color:#00007F">Dim</SPAN> iCELL <SPAN style="color:#00007F">As</SPAN> Range, RangeToDelete <SPAN style="color:#00007F">As</SPAN> Range
<SPAN style="color:#00007F">Dim</SPAN> StrDataRange <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>, StrAuxDataRange <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">String</SPAN>


    Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN>
    <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">Resume</SPAN> <SPAN style="color:#00007F">Next</SPAN>
    ActiveSheet.ShowAllData
    <SPAN style="color:#00007F">On</SPAN> <SPAN style="color:#00007F">Error</SPAN> <SPAN style="color:#00007F">GoTo</SPAN> 0
    
    <SPAN style="color:#007F00">'Use of an auxiliary data column</SPAN>
    Columns("B:B").Copy
    Columns("A:A").Insert Shift:=xlToRight <SPAN style="color:#007F00">'Now Data are in Column C</SPAN>
    
    <SPAN style="color:#007F00">'Set here Your Data Range address: source data are in column B,</SPAN>
    <SPAN style="color:#007F00">'but now data are in column C, in this example "C1:C14" Update last row cell</SPAN>
    StrDataRange = "C1:C14" <SPAN style="color:#007F00">'Update first and last row index</SPAN>
    
    <SPAN style="color:#007F00">'Set here Your Auxiliary Data Range address: update last cell row</SPAN>
    StrAuxDataRange = "A2:A14" <SPAN style="color:#007F00">'The first row index is "1 + first row" of StrDataRange</SPAN>
                               <SPAN style="color:#007F00">'The last row index is the same of StrDataRange</SPAN>
    
    
    Range(StrAuxDataRange).Formula = "=C2" <SPAN style="color:#007F00">'Insert formula in all cell of auxiliary column</SPAN>
    <SPAN style="color:#007F00">'Advanced filter for Unique Copy detection</SPAN>
    Range(StrDataRange).AdvancedFilter Action:=xlFilterInPlace, Unique:=<SPAN style="color:#00007F">True</SPAN>
    <SPAN style="color:#007F00">'Replace formula with value in each unique copy cell</SPAN>
    <SPAN style="color:#00007F">For</SPAN> <SPAN style="color:#00007F">Each</SPAN> iCELL <SPAN style="color:#00007F">In</SPAN> Range(StrAuxDataRange).SpecialCells(xlCellTypeVisible)
        iCELL.Formula = iCELL
    <SPAN style="color:#00007F">Next</SPAN> iCELL
    <SPAN style="color:#007F00">'Clear filter</SPAN>
    ActiveSheet.ShowAllData
    <SPAN style="color:#007F00">'Acquisition of duplicates (have formula inside)</SPAN>
    <SPAN style="color:#00007F">Set</SPAN> RangeToDelete = Range(StrAuxDataRange).SpecialCells(xlCellTypeFormulas, xlTextValues)
    
    <SPAN style="color:#007F00">'Open Text File: I suppose it is "c:\test.txt"</SPAN>
    <SPAN style="color:#00007F">Const</SPAN> ForWriting <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Integer</SPAN> = 2
    <SPAN style="color:#00007F">Const</SPAN> CreateIfNotExist <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Boolean</SPAN> = <SPAN style="color:#00007F">True</SPAN>
    <SPAN style="color:#00007F">Dim</SPAN> fs, f
    <SPAN style="color:#00007F">Set</SPAN> fs = CreateObject("Scripting.FileSystemObject")
    <SPAN style="color:#00007F">Set</SPAN> f = fs.OpenTextFile("c:\test.txt", ForWriting, CreateIfNotExist)
    For <SPAN style="color:#00007F">Each</SPAN> iCELL <SPAN style="color:#00007F">In</SPAN> RangeToDelete
        f.WriteLine iCELL
    <SPAN style="color:#00007F">Next</SPAN> iCELL
    f.Close
    RangeToDelete.Rows.EntireRow.Delete Shift:=xlUp
    
    Columns("A:A").Delete Shift:=xlToLeft
    Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN>
    
<SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN>
<SPAN style="color:#00007F">Sub</SPAN> Macro3()</FONT>


Post for feedback

Ciao

 

[chiello]

Try the following code.
Remember to set correctly the following variables (as explained in the code):
StrDataRange
StrAuxDataRange

Code:

You can
Replace
StrDStrAuxDataRange = "A2:A14" 'The first row index is "1 + first row" of StrDataRange
StrAuxDataRange = "A2:A14" 'The first row index is "1 + first row" of StrDataRange

With
StrDataRange = "C1:C" & Cells(Cells.Rows.Count,3).End(xlUp).Row
StrAuxDataRange = "A2:A" & Cells(Cells.Rows.Count,1).End(xlUp).Row

 

[dmtcrainey]

Thanks for the help.

I decided to try something different though.

I have done some editing since I have last tested it so it may have bugs but....

I think I can get rid of the offset + 1 junk and it will work now. originally i was not deleing the row.


Sub FindDups()

option explicit

dim FirstItem as string
dim SecondItem as string
dim Offsetcount as int
dim IntRowNum as int

ScreenUpdating = False

AppendToTextFile(NOW() & "Start") ' Write time to excel file to keep track of dates

Rows("1:1").Delete Shift:=xlUp ' Delete Blank First Row

Range("A1").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom ' Sort List

Range("B1").Select

FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value

Offsetcount = 1

Do While ActiveCell <> ""

If FirstItem = SecondItem Then ' If Duplicate then

IntRowNum = ActiveCell.Offset(Offsetcount, 0).Row 'Find Row Number
AppendToTextFile (ActiveCell.Offset(Offsetcount, 0)) ' Write email address to file
Rows(IntRowNum).EntireRow.Delete ' Delete Entire Row
'Offsetcount = Offsetcount + 1 ' Since we deleted the row this is not needed
SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
Else
ActiveCell.Offset(Offsetcount, 0).Select
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
End If

Loop

ScreenUpdating = True

AppendToTextFile(NOW() & " Finish") ' Write time to excel file to keep track of dates

End Sub


Sub AppendToTextFile(email As String)

' Define Variable
Const strTextFileName As String = "C:\duplicates_log.txt"
Dim intHandle As Integer

intHandle = FreeFile

If Dir(strTextFileName) = "" Then 'Create file if it does not exist
Open strTextFileName For Output As #intHandle
Else
Open strTextFileName For Append As #intHandle
End If

Print #intHandle, email ' write email address to file

Close #intHandle

End Sub

 

[dmtcrainey]

I have now had a chance to edit my cose and test it a little bit.

Here is the final version. This code sorts the list of items and removes any duplicates lines based on the contents of column B.


Option Explicit

Sub FindDups()


Dim FirstItem As String
Dim SecondItem As String
Dim RowNum As Long

AppendToTextFile (Now() & "Start") ' Write time to excel file to keep track of dates

If Range("A1") = "" Then Rows("1:1").Delete Shift:=xlUp ' Delete Blank First Row

Range("A1").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom ' Sort List

Range("B1").Select

FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value

Do While ActiveCell <> ""

If FirstItem = SecondItem Then ' If Duplicate then

RowNum = ActiveCell.Offset(1, 0).Row 'Find Row Number
AppendToTextFile (ActiveCell.Offset(1, 0)) ' Write email address to file
Rows(RowNum).EntireRow.Delete ' Delete Entire Row
SecondItem = ActiveCell.Offset(1, 0).Value
Else
ActiveCell.Offset(1, 0).Select
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
End If

Loop
Range("A1").Select
AppendToTextFile (Now() & " Finish") ' Write time to excel file to keep track of dates

End Sub


Sub AppendToTextFile(email As String)

' Define Variable
Const strTextFileName As String = "C:\duplicates_log.txt"
Dim intHandle As Integer

intHandle = FreeFile

If Dir(strTextFileName) = "" Then 'Create file if it does not exist
Open strTextFileName For Output As #intHandle
Else
Open strTextFileName For Append As #intHandle
End If

Print #intHandle, email ' write email address to file

Close #intHandle

End Sub