Sort according to custom list

[urimagic]

Hi, my first time here. First of all, I would like to point out that I posted this problem with Excel help...The link is here..Sort according to custom list

I did get help but the code I was requesting did not work on my pc....only to find out a bit later I had by chance indicated I was using Excel 2013. That was a huge mistake...my other pc has Excel 2013, but the pc is malfunctioning, therefore me using this one....It has Excel 2007 installed. I replied back but I have not received response....So I'm trying here. I have downloaded and installed XL2BB, but I'm not able to work it...I'll be sure to check it out and hopefully next time I will be able to use it.

Okay, In column A is data going in. Column C is the sort list I want column A to automatically sort by. So as I enter data into column A, the data must sort automatically to look like the data set in column E. Column G represents the updated list once I had added for example, 1 Pear 2 in column A. Thanks for all the help and assistance. Appreciated.

 

[Alex Blakenburg]

Assuming your Sort By List is in column D per you post #9 and that Column B is empty, and ignoring your New List and New List 2 which need more exlanation, try this as a stand alone macro in the a standard module.
Please run it on a copy of your workbook it will overwrite column B is there is anything it.

If you want to automate it we can modify it to go into a worksheet change event but it might be a nuisance for it to run every time you make an entry.

Sub SortByList()

    Dim sht As Worksheet
    Dim sortbyRng As Range, srcRng As Range
    Dim sortbyLastRow As Long, srcLastRow As Long
    Dim sortbyArr As Variant, srcArr As Variant
    Dim dictSortBy As Object, dictKey As String
    Dim i As Long
    
    Set sht = ActiveSheet
    With sht
        sortbyLastRow = .Range("D" & Rows.Count).End(xlUp).Row
        Set sortbyRng = .Range("D1:D" & sortbyLastRow)
        sortbyArr = sortbyRng.Value
        
        srcLastRow = .Range("A" & Rows.Count).End(xlUp).Row
        Set srcRng = .Range("A1:A" & srcLastRow)
        srcArr = srcRng.Value
        ' Assume column B is empty
        ReDim Preserve srcArr(1 To UBound(srcArr, 1), 1 To 2)
    End With


    Set dictSortBy = CreateObject("Scripting.dictionary")
    
    ' Load sort by range into Dictionary
    For i = 1 To UBound(sortbyArr)
        dictKey = sortbyArr(i, 1)
        If Not dictSortBy.exists(dictKey) Then
            dictSortBy(dictKey) = i
        End If
    Next i
    
    For i = 1 To UBound(srcArr)
        dictKey = Left(srcArr(i, 1), InStrRev(srcArr(i, 1), " ") - 1)
        If dictSortBy.exists(dictKey) Then
            srcArr(i, 2) = dictSortBy(dictKey)
        Else
            srcArr(i, 2) = "Not in List"
        End If
    
    Next i
    
    Set srcRng = srcRng.Resize(, 2)
    srcRng.Columns(2).Value = Application.Index(srcArr, 0, 2)
    
    srcRng.Sort key1:=srcRng.Cells(1, 2), _
                Order1:=xlAscending, _
                Header:=xlNo
                
    srcRng.Columns(2).ClearContents
    
End Sub

 

[urimagic]

Well, that explains why the Custom Sort hasn't been working for you (I'll ignore the fact that the column containing the sort list is D and not C as per all your samples & descriptions to date because you must have adjusted the code to suit, otherwise you'd have gotten an error message). I'm not sure that you understand how a Custom sort works - suggest you have a look at this: Sort data using a custom list - Microsoft Support. As it stands, there isn't a single item in your column A that matches any item in column D - therefore, the Custom sort would have had zero effect. Not sure that I can help you any further on this. Good luck & best wishes.

Thanks for your feedback,

well, no the reason for nothing working is not because of different columns, etc....I know how to at least adjust a code to get what I want..I mean, as far as changing ranges is concerned, at least...I was just hoping to get a code that would look at the text portion of the input value, for example 1 Pet 2:5..so it finds "Pet", and then moves that data to the range of "Pet" as it is in the sort list, so the code determines what the "Pet" data must be before, and what it must be after, in the main list, and then puts it there. What I mean is this..lets say there are only 2 inputs in column A, lets say Exo 2:6 and Mat 3:9..for example, and I input Sag 5:2, The code must look at the sort list to "see" where SAG 5:2 must go between...then sees that it goes between Exo and Mat, so it inserts the data between those two. If I put Gen 3:6, the code realises that GEN goes right on top, and puts it on top in column A. Now a lst note, should I put Sag 4:8, moves that data to the "Sag" already in column A, but also above Sag 5:2....This was what I really wanted...don't know if you are still willing to see if you can help me....please?

 

[urimagic]

Assuming your Sort By List is in column D per you post #9 and that Column B is empty, and ignoring your New List and New List 2 which need more exlanation, try this as a stand alone macro in the a standard module.
Please run it on a copy of your workbook it will overwrite column B is there is anything it.

If you want to automate it we can modify it to go into a worksheet change event but it might be a nuisance for it to run every time you make an entry.

Sub SortByList()

    Dim sht As Worksheet
    Dim sortbyRng As Range, srcRng As Range
    Dim sortbyLastRow As Long, srcLastRow As Long
    Dim sortbyArr As Variant, srcArr As Variant
    Dim dictSortBy As Object, dictKey As String
    Dim i As Long
   
    Set sht = ActiveSheet
    With sht
        sortbyLastRow = .Range("D" & Rows.Count).End(xlUp).Row
        Set sortbyRng = .Range("D1:D" & sortbyLastRow)
        sortbyArr = sortbyRng.Value
       
        srcLastRow = .Range("A" & Rows.Count).End(xlUp).Row
        Set srcRng = .Range("A1:A" & srcLastRow)
        srcArr = srcRng.Value
        ' Assume column B is empty
        ReDim Preserve srcArr(1 To UBound(srcArr, 1), 1 To 2)
    End With


    Set dictSortBy = CreateObject("Scripting.dictionary")
   
    ' Load sort by range into Dictionary
    For i = 1 To UBound(sortbyArr)
        dictKey = sortbyArr(i, 1)
        If Not dictSortBy.exists(dictKey) Then
            dictSortBy(dictKey) = i
        End If
    Next i
   
    For i = 1 To UBound(srcArr)
        dictKey = Left(srcArr(i, 1), InStrRev(srcArr(i, 1), " ") - 1)
        If dictSortBy.exists(dictKey) Then
            srcArr(i, 2) = dictSortBy(dictKey)
        Else
            srcArr(i, 2) = "Not in List"
        End If
   
    Next i
   
    Set srcRng = srcRng.Resize(, 2)
    srcRng.Columns(2).Value = Application.Index(srcArr, 0, 2)
   
    srcRng.Sort key1:=srcRng.Cells(1, 2), _
                Order1:=xlAscending, _
                Header:=xlNo
               
    srcRng.Columns(2).ClearContents
   
End Sub

Hallo Alex Blakenburg,

THANK YOU KINDLY...the code works 100%...I do appreciate this a heck of a lot....I am really grateful..Thanks

 

[Alex Blakenburg]

You're welcome. Glad we could help.
Your sample on post #9 made the patterns in the data much clearer and we wouldn't have gotten to that point without @kevin9999's contribution.

 

[urimagic]

You're welcome. Glad we could help.
Your sample on post #9 made the patterns in the data much clearer and we wouldn't have gotten to that point without @kevin9999's contribution.

Absolutely, I agree 100%...next time I'll just post original work as opposed to a dummy sheet with dummy data....thank you...stay blessed.

 

[urimagic]

You're welcome. Glad we could help.
Your sample on post #9 made the patterns in the data much clearer and we wouldn't have gotten to that point without @kevin9999's contribution.

Hi Alex Blakenburg,

Sorry to trouble you again...I have noticed 5 entries just refuse to sort. I have highlighted them in yellow. I re-typed them, however for some reason they just do not sort...Would you kindly please check maybe why that is?..please?..

Tekse sort.xlsm
	A			D
1	Num 23:19			Gen
2	Jes 29:13			Exo
3	Mig 6:8			Lev
4	Luk 9:23			Num
5	Joh 1:12			Deu
6	Joh 3:3			Jos
7	Joh 8:32			Rig
8	Joh 4:23			Rut
9	Joh 4:24			1 Sam
10	Joh 14:6			2 Sam
11	Rom 3:23			1 Kon
12	Rom 4:25			2 Kon
13	Rom 5:12			1 Kro
14	Rom 5:18			2 Kro
15	Rom 6:6			Esr
16	Rom 6:23			Neh
17	Rom 8:1			Est
18	Rom 8:5			Job
19	Rom 6:2			Psa
20	Rom 6:3			Spr
21	Rom 6:4			Pre
22	Rom 6:1			Hoo
23	2 Kor 5:17			Jes
24	Gal 2:20			Jer
25	Efe 1:3			Kla
26	Efe 2:8			Ese
27	Efe 2:9			Dan
28	Kol 2:13			Hos
29	Kol 2:14			Joe
30	Kol 2:15			Amo
31	2 Tim 3:5			Oba
32	Heb 4:16			Jon
33	Heb 11:1			Mig
34	Heb 11:6			Nah
35	Heb 13:5			Hab
36	Jak 1:2			Sef
37	Jak 1:3			Hag
38	Jak 1:4			Sag
39	Jak 1:5			Mal
40	Jak 1:6			Mat
41	Jak 1:7			Mar
42	Jak 2:19			Luk
43	Jak 2:20			Joh
44	Jak 4:7			Han
45	Jak 5:14			Rom
46	Jak 5:15			1 Kor
47	Jak 5:16			2 Kor
48	1 Pet 3:18			Gal
49	1 Pet 5:7			Efe
50	1 Pet 5:8			Fill
51	1 Joh 2:6			Kol
52	1 Joh 5:4			1 The
53	1 Joh 5:5			2 The
54				1 Tim
55				2 Tim
56				Tit
57				Fil
58				Heb
59				Jak
60				1 Pet
61				2 Pet
62				1 Joh
63				2 Joh
64				3 Joh
65				Jud
66				Ope
Sheet1

 

[Akuini]

@urimagic try this:
I assumed:
1. Data in col A always has numbers at the end, separated by ":" , such as 3:34, 45:67 etc.
2, Col B:C is blank, they are used as temporary helper column:

Sub urimagic1()
Dim va, vb
Dim c As Range

Set c = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 3)
va = c.Value
vb = Range("D1", Cells(Rows.Count, "D").End(xlUp))

For i = 1 To UBound(va, 1)
    For j = 1 To UBound(vb, 1)
        If InStr(va(i, 1), vb(j, 1)) = 1 Then
            va(i, 2) = j
            Exit For
        End If
    Next
Next

For i = 1 To UBound(va, 1)
        a = Split(va(i, 1), " ")
        b = Split(a(UBound(a)), ":")
        va(i, 3) = Format(b(0), "0000") & "|" & Format(b(1), "0000")
Next

Range("A1").Resize(UBound(va, 1), 3) = va

c.Sort Key1:=c.Columns(2), Order1:=xlAscending, Key2:=c.Columns(3), Order2:=xlAscending, Header:=xlNo
c.Offset(, 1).Resize(, 2).ClearContents
End Sub

Book1
	A	B	C	D
1	Num 23:19			Gen
2	Jes 29:13			Exo
3	Mig 6:8			Lev
4	Luk 9:23			Num
5	Joh 1:12			Deu
6	Joh 3:3			Jos
7	Joh 4:23			Rig
8	Joh 4:24			Rut
9	Joh 8:32			1 Sam
10	Joh 14:6			2 Sam
11	Rom 3:23			1 Kon
12	Rom 4:25			2 Kon
13	Rom 5:12			1 Kro
14	Rom 5:18			2 Kro
15	Rom 6:1			Esr
16	Rom 6:2			Neh
17	Rom 6:3			Est
18	Rom 6:4			Job
19	Rom 6:6			Psa
20	Rom 6:23			Spr
21	Rom 8:1			Pre
22	Rom 8:5			Hoo
23	2 Kor 5:17			Jes
24	Gal 2:20			Jer
25	Efe 1:3			Kla
26	Efe 2:8			Ese
27	Efe 2:9			Dan
28	Kol 2:13			Hos
29	Kol 2:14			Joe
30	Kol 2:15			Amo
31	2 Tim 3:5			Oba
32	Heb 4:16			Jon
33	Heb 11:1			Mig
34	Heb 11:6			Nah
35	Heb 13:5			Hab
36	Jak 1:2			Sef
37	Jak 1:3			Hag
38	Jak 1:4			Sag
39	Jak 1:5			Mal
40	Jak 1:6			Mat
41	Jak 1:7			Mar
42	Jak 2:19			Luk
43	Jak 2:20			Joh
44	Jak 4:7			Han
45	Jak 5:14			Rom
46	Jak 5:15			1 Kor
47	Jak 5:16			2 Kor
48	1 Pet 3:18			Gal
49	1 Pet 5:7			Efe
50	1 Pet 5:8			Fill
51	1 Joh 2:6			Kol
52	1 Joh 5:4			1 The
53	1 Joh 5:5			2 The
54				1 Tim
55				2 Tim
56				Tit
57				Fil
58				Heb
59				Jak
60				1 Pet
61				2 Pet
62				1 Joh
63				2 Joh
64				3 Joh
65				Jud
66				Ope
Sheet1

 

[Alex Blakenburg]

@urimagic - assuming 1:2 means 1 hr 2 mins, then @Akuini's code will do what you seem to be trying to do.
Although using a dictionary will be faster in some scenarios, since Akuini's code completes in under 0.5 secs for 10k rows given your example sort list in column D, it would be hardly noticeable.
If performance does become an issue let us know and I can look at modifying my dictionary solution to sort on the time component as a secondary sort.

 

[urimagic]

@urimagic - assuming 1:2 means 1 hr 2 mins, then @Akuini's code will do what you seem to be trying to do.
Although using a dictionary will be faster in some scenarios, since Akuini's code completes in under 0.5 secs for 10k rows given your example sort list in column D, it would be hardly noticeable.
If performance does become an issue let us know and I can look at modifying my dictionary solution to sort on the time component as a secondary sort.

Hi Alex Blakenburg,

Splendid work, thank you so very much...performance really is currently not an issue, thank you...I honestly appreciate your time with this...stay blessed..

 

[Akuini]

@urimagic
Did you try my code in post #17?