Re-order a group of cells based on a list

I have text in a single cell that's separated by a "/" that i'd like to reorder within the cell based on a list in a separate .xls file e.g.

In one cell i have "Benton/Ames/Depew/Quitman" 

I have a list in a separate xls file that reads vertically:

Depew

Ames

Chickasaw

Sheridan

Quitman

Federal

Benton

I'd like to reorder the contents of the cell based on the list.  So it would read "Depew/Ames/Quitman/Benton". There are not more than 5 things to reorder in a cell and the list to sort from is maybe 20 long. Everything is text, and occasionally the things repeat (e.g. "Ames/Ames/Quitman"). If they repeat, I'd like to delete the extra (So "Ames/Quitman" from the previous example). I've figured out a way to delete the extra, but I can't think of how to sort them correctly.

Any help would be greatly appreciated.

torre751

You are stretching it there. The only way you will be able to do this is with a decent amount of VBA code. First to parse the data in a single cell and then to apply a cutom sort. IMHO, not a trivial matter

I thought that on first reading Nick, but on reflection, it may not be that hard.

Get the cell items using Split, drop it into a range, create a custom list from the original data, sort it using Excel's sort, Join the range, and replace.

Might have a go tomorrow.

Okay, money where your mouth is time!

Public Function SortCellSpecial()
Dim LastRow
Dim CustomListNum As Long
Dim aryItems
Dim rng As Range

    With Workbooks("CustomSortList.xls").Worksheets(1)
    
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Application.AddCustomList ListArray:=.Range("A1").Resize(LastRow)
        CustomListNum = GetListNum(.Range("A1").Resize(LastRow))
    End With

    With ActiveSheet
        
        aryItems = Split(.Range("A1"), "/")
        Set rng = .Range("H1").Resize(UBound(aryItems) - LBound(aryItems) + 1)
        rng = Application.Transpose(aryItems)
        
        rng.Sort Key1:=.Range("H1"), _
                 Order1:=xlAscending, _
                 Header:=xlNo, _
                 OrderCustom:=CustomListNum + 1, _
                 MatchCase:=False, _
                 Orientation:=xlTopToBottom
                       
        aryItems = Application.Transpose(rng)
        .Range("A1").Value = Join(aryItems, "/")
        rng.ClearContents
    End With
    
    Application.DeleteCustomList listnum:=CustomListNum

End Function
 
Private Function GetListNum(ByRef rng As Range) As Variant
Dim i As Long, j As Long
Dim ary
Dim OK As Boolean
Dim cell As Range
     
    For i = 1 To Application.CustomListCount
        ary = Application.GetCustomListContents(i)
        j = LBound(ary)

        OK = True
        For Each cell In rng
            
            If cell.Value <> ary(j) Then
            
                OK = False
                Exit For
            End If
            j = j + 1
        Next cell
        
        If OK Then
            
            GetListNum = i
            Exit For
        End If
    Next i
End Function
 

Bob

Split and Join...why didn't I think of that? It looked far more complicated than that, so now to jump on your glory, why the extra private function? I amended it like so...

Public Function SortCellSpecial()
Dim LastRow
Dim CustomListNum As Long
Dim aryItems
Dim rng As Range

    With Workbooks("CustomSortList.xls").Worksheets(1)
    
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Application.AddCustomList ListArray:=.Range("A1").Resize(LastRow)
        CustomListNum = Application.GetCustomListNum(.Range("A1").Resize(LastRow).Value)
    End With

    With ActiveSheet
        
        aryItems = Split(.Range("A1"), "/")
        Set rng = .Range("H1").Resize(UBound(aryItems) - LBound(aryItems) + 1)
        rng = Application.Transpose(aryItems)
        
        rng.Sort Key1:=.Range("H1"), _
                 Order1:=xlAscending, _
                 Header:=xlNo, _
                 OrderCustom:=CustomListNum + 1, _
                 MatchCase:=False, _
                 Orientation:=xlTopToBottom
                       
        aryItems = Application.Transpose(rng)
        .Range("A1").Value = Join(aryItems, "/")
        rng.ClearContents
    End With
    
    Application.DeleteCustomList listnum:=CustomListNum

End Function

Didn't spot GetCustomListNum when I wrote it.

BTW, what tags do you use for that better formatted code?

Bob

I'm also not sure 'we' couldn't have just taken the count and run with that as the added one is added to the end of the list of custom sorts anyhow.

On the code front. It does make a pretty good job, but is more convaluted than the [code] tags you are using. I use Windows Live Writer (WLW) for all my blog posting and that allows add-ons, one of which is a code snippet one. I just paste my code in the window and select either VB for VBA or HTML for RibbonX and it makes a pretty good stab. The best bit is you can copy and paste it into VBE without all the garbage that seems to appear with [code].

I originally thought that back a couple of years ago when I came up with this VBA sorting technique, but guess what, I found that it wasn't always true. And why is the list number offset by 1 in the Sort argument? Typical consistent MS.

I think I will pass on the tags. Although Karl Peterson gave me something once that formats code, I will try and dig that out and see how it works.

 Thank you Nick and Bob, that works tremendously well.  I really do appreciate the assistance.

When i'm running through the code, testing and making modifications, I'll hit a runtime error 1004 when i get to the bold/italicized line below.  I did a little research and found that it was because a custom list that was identical already exists.  I tried moving the Application.DeleteCustomList listnum:=CustomListNum further ahead to delete the custom list before recreating it (if what I said makes any sense) and no dice.  I also tried assigning the range to a variable as is commented out in the italicized portion of code below and still no dice.  This error seems to come and go while I'm fiddling with things, I'm sure there's a reason, it's just beyond my understanding.

Hats off to you both though, I am very grateful and thanks again.

Option Explicit
Private Function AbbreviationSorter()
Dim LastRow As Double
Dim CustomListNum As Long
Dim aryItems As Variant
Dim rng As Range
Dim k As Long
Dim rngCounter As Integer

        Application.DeleteCustomList listnum:=CustomListNum
       
    With Workbooks("Strat Column Abbreviations.xls").Worksheets(1)
    

        'LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        'TempArray = Range("A1").Resize(LastRow)
        'Application.AddCustomList ListArray:=TempArray
        'CustomListNum = GetListNum(.Range("A1").Resize(LastRow))

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Application.AddCustomList ListArray:=.Range("A1").Resize(LastRow)
        CustomListNum = Application.GetCustomListNum(.Range("A1").Resize(LastRow).Value)

    End With
   
For k = 14 To 1 Step -1
    If Cells(k, 2) <> "" Then
   
    With ActiveSheet
        aryItems = Split(.Cells(k, 8), "/")
        Set rng = .Cells(k, 13).Resize(UBound(aryItems) - LBound(aryItems) + 1)
        rngCounter = rng.Count
       
        If rngCounter > 1 Then
            rng = Application.Transpose(aryItems)
            rng.Sort Key1:=.Cells(k, 13), _
                     Order1:=xlAscending, _
                     Header:=xlNo, _
                     OrderCustom:=CustomListNum + 1, _
                     MatchCase:=False, _
                     Orientation:=xlTopToBottom
                          
            aryItems = Application.Transpose(rng)
            .Cells(k, 8).Value = Join(aryItems, "/")
        End If
        rng.ClearContents
    End With
   
    End If
Next k

    Application.DeleteCustomList listnum:=CustomListNum

End Function

I thought we had lost you.

As to the code, test whether the list exists before adding it

<pre>

Private Function AbbreviationSorter()
Dim LastRow As Double
Dim CustomListNum As Long
Dim aryItems As Variant
Dim rng As Range
Dim k As Long
Dim rngCounter As Integer

    With Workbooks("Strat Column Abbreviations.xls").Worksheets(1)
   
        'LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        'TempArray = Range("A1").Resize(LastRow)
        'Application.AddCustomList ListArray:=TempArray
        'CustomListNum = GetListNum(.Range("A1").Resize(LastRow))
   
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        CustomListNum = Application.GetCustomListNum(.Range("A1").Resize(LastRow).Value)
        If CustomListNum = 0 Then
       
            Application.AddCustomList ListArray:=.Range("A1").Resize(LastRow)
            CustomListNum = Application.GetCustomListNum(.Range("A1").Resize(LastRow).Value)
        End If

    End With
</pre>

BTW, just after this code, you use Activesheet. Is that correct?

 Bob-

I'm lost perhaps, but just drowning with other projects so this particular project was reduced to a simmer.

That if statement works quite well. I'm not familiar enough with custom lists to have a good sense of their functionality so I may ask very simple questions...

I do use activesheet after.  I use the macro with whatever particular spreadsheet i happen to be working with, but i'm not sure if that's the 'correct' way to go about it.

Cheers-

It is just that we start with the first worksheet in the nominated workbook, then we switch to Activesheet. They may not be the same sheet (they may not even be the same workbook).