February 24, 2008

JMT Excel Utilities Updated

I have been updating my main utilities again. I have not added anything new, just improved (debugged) some that I found that were not working properly with Excel 2007. I do intend to add some more utilities at a later date though.

Here's the download link. I've also done a little work on the Excel 97 - 2003 version, you will find it included in the same zip file. Don't forget they are free :-)  

Posted by andrewe at 10:06

February 17, 2008

Removing Duplicates and Non-matching Items 2

As promised last time, here is a way to remove duplicates in cells using VBA.

The picture below shows 2 columns. I want to remove duplicates from the second column by comparing them to values in the first column.



Here is the code.
Sub RemoveDuplicatesInCells()

    Dim c As Range
    Dim rCheckForDupes As Range

    Set rCheckForDupes = Range("A1:B14")

    With rCheckForDupes

        For Each c In .Columns(2).Cells

            If WorksheetFunction.CountIf(.Columns(1), c.Value) > 0 Then
                c.ClearContents
            End If

        Next c

    End With

    Set rCheckForDupes = Nothing

End Sub

And the result.



But how about those blank cells? Let's modify the code to remove them.
Sub RemoveDuplicatesInCells2()

    Dim c As Range
    Dim rCheckForDupes As Range

    Set rCheckForDupes = Range("A1:B14")

    With rCheckForDupes

        For Each c In .Columns(2).Cells

            If WorksheetFunction.CountIf(.Columns(1), c.Value) > 0 Then
                c.ClearContents
            End If

        Next c

        .Columns(2).SpecialCells(xlCellTypeBlanks).Select

        Selection.Delete Shift:=xlUp

        .Cells(1).Select

    End With

    Set rCheckForDupes = Nothing

End Sub

Now they are gone.



To remove non-matching items, change the greater than (>) sign in "If WorksheetFunction.CountIf(.Columns(1), c.Value) > 0" to an equal (=) sign. Easy :-)  
Posted by andrewe at 17:04

February 09, 2008

Removing Duplicates and Non-matching Items

Here is a way to remove duplicates from a list box. The code below loops though each item in the second list, comparing it against items in the first list by looping through them in a secondary loop. If any items in the second list are found to match those in the first list, they are placed in an array (recording their position on the list). Then the code loops though the array backwards to remove them. Looping backwards ensures that the correct items are deleted as removing items actually changes the items position on the list.

Private Sub cbRemoveDuplicates_Click()

    Dim iCheck As Long
    Dim iCheck2 As Long
    Dim bFound As Boolean
    Dim iCount As Long
    Dim iListCount As Long
    Dim iListNumber As Long
    Dim aRemove()

    iListCount = ListBox2.ListCount

    On Error Resume Next

    For iCheck2 = 0 To ListBox2.ListCount - 1

        bFound = False

        For iCheck = 0 To ListBox1.ListCount - 1

            If ListBox2.List(iCheck2) = ListBox1.List(iCheck) Then

                bFound = True

            End If

        Next iCheck

        If bFound = True Then

            ReDim Preserve aRemove(iListNumber)
            aRemove(iListNumber) = iCheck2
            iListNumber = iListNumber + 1

        End If

    Next iCheck2

    For iListNumber = UBound(aRemove) To LBound(aRemove) Step -1

        ListBox2.RemoveItem aRemove(iListNumber)

        iCount = iCount + 1

        If iCount > iListCount Then Exit For

    Next iListNumber

    On Error GoTo 0
End Sub

You might notice that some error proofing code is added to prevent looping through the array too many times, this is just in case there are no items in either of the lists.

By changing " If bFound = True Then" before adding items to the array to "If bFound = False Then", we can use the same technique to remove non-matching items (items from the second list that are not found on the first list)

Private Sub cbRemoveNonMatches_Click()

    Dim iCheck As Long
    Dim iCheck2 As Long
    Dim bFound As Boolean
    Dim iCount As Long
    Dim iListCount As Long
    Dim iListNumber As Long
    Dim aRemove()

    iListCount = ListBox2.ListCount

    On Error Resume Next

    For iCheck2 = 0 To ListBox2.ListCount - 1

        bFound = False

        For iCheck = 0 To ListBox1.ListCount - 1

            If ListBox2.List(iCheck2) = ListBox1.List(iCheck) Then

                bFound = True

            End If

        Next iCheck

        If bFound = False Then

            ReDim Preserve aRemove(iListNumber)
            aRemove(iListNumber) = iCheck2
            iListNumber = iListNumber + 1

        End If

    Next iCheck2

    For iListNumber = UBound(aRemove) To LBound(aRemove) Step -1

        ListBox2.RemoveItem aRemove(iListNumber)

        iCount = iCount + 1

        If iCount > iListCount Then Exit For

    Next iListNumber

    On Error GoTo 0
End Sub

To do the same with values in cells is pretty easy. Maybe I'll post that code next time.  
Posted by andrewe at 15:04