Sorting a range with respect to other range

[somnath6309]

Dear Friends,

last time due to some internet problem, I was unable to upload properly my requirement.

Please find enclosed herewith an excel file. The sheet1 is the table that should be sorted.
Most of the persons in Col B are same as persons in Col C. Actually the names may differ e.g. Dave and Dave L, Peter G and Peter etc.

We have to sort the range C1 to C13 with respect to the elements in B1 to B13. Following are the requirements:

I. Compare each element of range C1:C13 with each element of Range B1:B13 with the help of vba LIKE Operator.

II. If one element of col C approximately matches with one element of Col B, then the matching elements will be arranged side by side and hence, the range C1:C13 will be sorted with respect to range B1:B13

III. There are elements in both the columns that does not match each other e.g. SOMNATH, SOURAV, ASIM etc. In Col B & ANIL, PULAK, ANKIT etc. In Col C. These elements will be kept at last of both the columns.

the finished output (desired) will be found at sheet2 of the same workbook. Is it possible to create a sub/function procedure in vba that can accomplish the task ?

Regards,
Somnath

 

[Luke M]

A bit ugly, but this will get the job done.

Sub BuildDictionary()
Dim myRange As Range
Dim badCol As Collection
Dim newCol As Collection
Dim keyCount As Long
Dim itemCount As Long
Dim badCount As Long
Dim splitText As Variant
Dim testName As String
Dim curKey As String
Dim valFound As Boolean
Dim i As Variant

Set badCol = New Collection
Set newCol = New Collection
Application.ScreenUpdating = False

'Pull all our values
Set myRange = Worksheets("Sheet1").Range("C2:D14")

'Load all values initially
For itemCount = 1 To myRange.Rows.Count
    badCol.Add myRange.Cells(itemCount, 2)
Next

badCount = 0
Application.ScreenUpdating = False

'Start building dictionary
For keyCount = 1 To myRange.Rows.Count
    valFound = False
    curKey = myRange.Cells(keyCount, 1).Value
    For itemCount = 1 To badCol.Count
        'Only take the first name for comparison
        splitText = Split(badCol(itemCount), " ")
        testName = splitText(0)
       
        If curKey Like testName & "*" Then
            valFound = True
            Exit For
        End If
    Next itemCount
   
   
    If valFound Then
        'If match found, place it in new collection before the bad entries, remove item from starting list
        If newCol.Count > 0 Then
            newCol.Add Array(curKey, badCol(itemCount)), curKey, , newCol.Count - badCount
        Else
            newCol.Add Array(curKey, myRange.Cells(itemCount, 2).Value), curKey
        End If
        'Remove item from list, since we found it's match already
        badCol.Remove (itemCount)
    Else
        'If it wasn't found, place key at end of list, and leave item in starting bad list
        badCount = badCount + 1
        newCol.Add Array(curKey, " "), curKey, , newCol.Count
    End If
Next keyCount

'Output to sheet3, for now
keyCount = 1
With Worksheets("Sheet3")
    For Each i In newCol
        .Cells(keyCount, 1).Value = i(0)
        .Cells(keyCount, 2).Value = i(1)
        keyCount = keyCount + 1
    Next

    'Fill in any bad entries that remained
    For itemCount = 1 To badCount
        .Cells(newCol.Count + itemCount - badCount, 2).Value = badCol(itemCount)
    Next itemCount
End With
Application.ScreenUpdating = True

End Sub