Help with modifying a working macro

[Dan Wilson]

Good day. This should be a fun one. I am using Excel 2007 on Windows Vista Business 32 bit. I have a workbook that I just created that contains only 3 columns. It is an inventory of 200 CDs that I have created over the last 5 years (1 each week) to be used on my radio show. Each CD holds requests for one week that were not in the station library. Due to not having the inventory created until now, many of the songs are duplicated over several CDs and thus entered into the workbook several times. I have created macros attached to buttons to sort the list by the 3 columns ( CD#, Title and Artist). I have attached a macro that was sent to me from the forum that works well in removing duplicate entries in one active column. Is there a way that this macro can be modified to work on two columns, specifically the Title and Artist. There are some songs that are recorded by more than one artist. I would like to get the inventory down to one entry per song. Currently the workbook contains over 1800 entries. The working macro is below:


Public Sub DeleteDuplicateRows()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DeleteDuplicateRows
' This will delete duplicate records, based on the Active Column. That is,
' if the same value is found more than once in the Active Column, all but
' the first (lowest row number) will be deleted.
'
' To run the macro, select the entire column you wish to scan for
' duplicates, and run this procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim r As Long
Dim n As Long
Dim V As Variant
Dim Rng As Range
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")
n = 0
For r = Rng.Rows.Count To 2 Step -1
If r Mod 500 = 0 Then
Application.StatusBar = "Processing Row: " & Format(r, "#,##0")
End If
V = Rng.Cells(r, 1).Value
If V = vbNullString Then
If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
Rng.Rows(r).EntireRow.Delete
n = n + 1
End If
Else
If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
Rng.Rows(r).EntireRow.Delete
n = n + 1
End If
End If
Next r
EndMacro:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr
End Sub


The columns in question will be "B" and "C" in my new workbook. Any help on this one will be greatly appreciated.

 

[mirabeau]

Good day. This should be a fun one. I am using Excel 2007 on Windows Vista Business 32 bit. I have a workbook that I just created that contains only 3 columns. It is an inventory of 200 CDs that I have created over the last 5 years (1 each week) to be used on my radio show. Each CD holds requests for one week that were not in the station library. Due to not having the inventory created until now, many of the songs are duplicated over several CDs and thus entered into the workbook several times. I have created macros attached to buttons to sort the list by the 3 columns ( CD#, Title and Artist). I have attached a macro that was sent to me from the forum that works well in removing duplicate entries in one active column. Is there a way that this macro can be modified to work on two columns, specifically the Title and Artist. There are some songs that are recorded by more than one artist. I would like to get the inventory down to one entry per song. Currently the workbook contains over 1800 entries. The working macro is below:
...
...


The columns in question will be "B" and "C" in my new workbook. Any help on this one will be greatly appreciated.

would you consider an alternative macro?

Sub xdckj()

Dim d As Object, a, b(), x
Dim i As Long, j As Long, c As Long, rws As Long

Set d = CreateObject("scripting.dictionary")
rws = Range("B:C").Find("*", _
        searchorder:=xlByRows, searchdirection:=xlPrevious).Row
ReDim b(1 To rws, 1 To 3)
a = Range("A1").Resize(rws, 3)

For i = 2 To rws
    x = a(i, 2) & Chr(30) & a(i, 3)
    If d(x) = vbNullString Then
        d(x) = 1
        c = c + 1
        For j = 1 To 3
            b(c, j) = a(i, j)
        Next j
    End If
Next i

Range("A2").Resize(rws - 1, 3).ClearContents
Range("A2").Resize(c, 3) = b

End Sub

 

[FormR]

Another alternative to try:-

Sub DeleteDuplicateRows()
ActiveSheet.Range("A:C").RemoveDuplicates Columns:=Array(2, 3), Header:=xlYes
End Sub

 

[mirabeau]

Excel Remove Duplicates function maybe OK if

(a) have Excel 2007 or later

(b) are confident of avoiding the bug(s)
Possible Bug in Remove Duplicates Function? - Microsoft Community
and
http://www.mrexcel.com/forum/excel-...-duplicates-functionality-seems-have-bug.html
etc.

 

[FormR]

(a)

I am using Excel 2007 on Windows Vista Business 32 bit.

(b)

Agreed and worth checking.

 

[Dan Wilson]

Good day mirabeua. I can't thank you enough for your response. Not only did it work the first time, it worked better than I could have imagined. Sometimes when I enter data into my workbooks, I miss the proper letter casing. For instance one time I will enter "Get A Job" and another time it will be "Get a Job". Not only does your macro delete the duplicate entries, it finds errors of this type and leaves both versions there so I can sort on the Title and find them. I don't have a clue how your macro works. I spent a few years programming in DOS and other languages, but I never mastered the logic of Basic. I envy your knowledge. At the age of 70, I don't expect that I will master Basic. As long as there are people like you on the forum, I will get by. Thank you again for your help.

 

[Dan Wilson]

Good day FormR. Thank you for responding to my question. I will try your suggestion even though the fix from mirabeau is working well. I appreciate the response.

 

[lancerj017]

Add d.comparemode in mirabeau's code.

Try this:

Sub xdckj()
Dim d As Object, a, b(), x
Dim i As Long, j As Long, c As Long, rws As Long
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare 'This code should be here to match up the data
rws = Range("B:C").Find("*", _
        searchorder:=xlByRows, searchdirection:=xlPrevious).Row
ReDim b(1 To rws, 1 To 3)
a = Range("A1").Resize(rws, 3)


For i = 2 To rws
    x = a(i, 2) & Chr(30) & a(i, 3)
    If d(x) = vbNullString Then
        d(x) = 1
        c = c + 1
        For j = 1 To 3
            b(c, j) = a(i, j)
        Next j
    End If
Next i


Range("A2").Resize(rws - 1, 3).ClearContents
Range("A2").Resize(c, 3) = b


End Sub

 

[mirabeau]

...
At the age of 70, I don't expect that I will master Basic.
...

Dan,

Keep it up. You're doing fine. 70 sounds like a good age.

You can easily get reasonably good at Visual Basic at any age.

I'm not sure if anyone really really masters it, but there's always plenty of good and willing advice on this forum.