Help with macro to custom sort?

[Coyotex3]

Hello guys can you guys possibly help me sort a range/table(open to whichever is easier)

Book1
	B	C	D
1	Names	Description	ID
2	John Cena	You Can't See Me- John Cena	5
3	The Undertaker	Time to Play The Game- Triple H	6
4	Funaki	Heartbreak Kid- Shawn Michaels	8
5	Rico	Can you Smell- The Rdock	7
6	Eugene	I don't Know-Eugene	4
7	Triple H	SmackDown's number one Announcer- Funaki	2
8	The Rock	Rest in Peace- The Undertaker	3
9	Shawn Michaels	Kiss me- Rico	1
10		That's the Bottom Line- Stone Cold	9
11		Here Comes the Pain- Brock Lesnar	10
Sheet1

I would like to sort to it to look like this

Book1
	B	C	D
15	Names	Description	ID
16	John Cena	You Can't See Me- John Cena	5
17	Funaki	SmackDown's number one Announcer- Funaki	2
18	The Rock	Can you Smell- The Rdock	7
19
20
Sheet1

Essentially matching the name on Column B with the similar name in column C and sort while keeping columns C and D aligned

 

[Siddharth Rout]

The 3rd one can pose a challenge as The Rock is not present in the text Can you Smell- The Rdock. And if you consider Rock and Rdock similar then that can give you lot of false positives.

If you are just looking for the exact presense of column B in column C then that is possible using Autofilter - Contains.

 

[BSALV]

Sub CustomS()
     Dim f()
     Set dict = CreateObject("scripting.dictionary")
     dict.Add dict.Count, Array("Names", "Description", "ID")

     Set c = Range(Range("B2"), Range("B2").End(xlDown))
     mynames = c.Value                                          'array with the names
     Set c = Range(Range("C2"), Range("C2").End(xlDown)).Resize(, 2)
     mydescriptions = c.Value                                   'array with the description & ID
     kol_c = Application.Transpose(Application.Index(mydescriptions, 0, 1))     'array with only the description

     For i = 1 To UBound(mynames)                               'loop through names
          fl = Filter(kol_c, mynames(i, 1), 1, vbTextCompare)   'filter description on the name
          If UBound(fl) <> -1 Then                              'at least 1 matching ?
               For j = 0 To UBound(fl)                          'loop through matches
                    r = Application.Match(fl(j), kol_c, 0)      'find according row in kol_C
                    dict.Add dict.Count, Array(mynames(i, 1), mydescriptions(r, 1), mydescriptions(r, 2))     'add data to dictionary
               Next
          End If
     Next

     With Range("F1")                                           'outputrange
          .Resize(100, 3).ClearContents                         'clear former data
          .Resize(dict.Count, 3).Value = Application.Index(dict.items, 0, 0)     'write new data
     End With
End Sub

 

[Coyotex3]

The 3rd one can pose a challenge as The Rock is not present in the text Can you Smell- The Rdock. And if you consider Rock and Rdock similar then that can give you lot of false positives.

If you are just looking for the exact presense of column B in column C then that is possible using Autofilter - Contains.

Thank you for picking up on that typo. I am looking for the exact name presence yes. I will have to look into AutoFilters as I do not know much.

 

[Coyotex3]

Sub CustomS()
     Dim f()
     Set dict = CreateObject("scripting.dictionary")
     dict.Add dict.Count, Array("Names", "Description", "ID")

     Set c = Range(Range("B2"), Range("B2").End(xlDown))
     mynames = c.Value                                          'array with the names
     Set c = Range(Range("C2"), Range("C2").End(xlDown)).Resize(, 2)
     mydescriptions = c.Value                                   'array with the description & ID
     kol_c = Application.Transpose(Application.Index(mydescriptions, 0, 1))     'array with only the description

     For i = 1 To UBound(mynames)                               'loop through names
          fl = Filter(kol_c, mynames(i, 1), 1, vbTextCompare)   'filter description on the name
          If UBound(fl) <> -1 Then                              'at least 1 matching ?
               For j = 0 To UBound(fl)                          'loop through matches
                    r = Application.Match(fl(j), kol_c, 0)      'find according row in kol_C
                    dict.Add dict.Count, Array(mynames(i, 1), mydescriptions(r, 1), mydescriptions(r, 2))     'add data to dictionary
               Next
          End If
     Next

     With Range("F1")                                           'outputrange
          .Resize(100, 3).ClearContents                         'clear former data
          .Resize(dict.Count, 3).Value = Application.Index(dict.items, 0, 0)     'write new data
     End With
End Sub

This is brilliant mate! Thank you.