Ordering a list using VBA based on non-exact values in cells


I'm new to VBA and was hoping I could get some guidance on sorting and ordering.

I have a table of information with about 200 rows and 5 columns. In Column B there is "additional information" and I'm looking to identify which rows have text that contains in part any of the following words: "Training", "Admin", "General" and "Extra Info" and group them together.

So an example would be: Personal Admin, Work Admin, Weight Training, DD Extra Info, Training for EAS, General Write Ups.

So I need to be able to sort and order the whole row based only on part of each cell's value.

Hope that makes sense - I'd really appreciate any guidance!

I've used this custom list in the past to find and sort exact phrases:

Dim nCustomSort As Variant
Dim xx As Long

nCustomSort = Array("Training", "Admin", "General", "Extra Info")

Application.AddCustomList ListArray:=nCustomSort

With Worksheets("Sheet1")
xx = .Cells(Rows.Count, "B").End(xlUp).Row
  With .Range("A1:Z1000" & xx)
  .Cells.Sort Key1:=.Columns(2), Order1:=xlAscending, _
              Orientation:=xlTopToBottom, Header:=xlYes, MatchCase:=False, _
              OrderCustom:=Application.CustomListCount + 1

  End With
End With

Show source
| excel-vba   | vba   2017-01-06 14:01 2 Answers

Answers ( 2 )

  1. 2017-01-06 15:01

    From what I can see, you can't use wildcards in custom lists to sort data.

    The code below shows a generic substring sorting function which allows case matching and extended arrays of substrings to test.

    Sub ArraySort()
        Dim CustomSort() As Variant: CustomSort = Array("Training", "Admin", "General", "Extra Info")
        Dim wsSort As Worksheet: Set wsSort = Worksheets("Sheet1")
        Dim SortRange As Range: Set SortRange = wsSort.UsedRange
        SubstringSort SortRange, 2, CustomSort, True, True
    End Sub
    Function SubstringSort(SortRange As Range, _
        SortColumn As Long, _
        SortArray() As Variant, _
        Optional Header As Boolean, _
        Optional MatchCase As Boolean) As Boolean
        ' SortColumn is the column index within the SortRange to sort via substring lookup
        ' SortArray is the array of substrings to search for
        If IsMissing(Header) Then Header = False
        If IsMissing(MatchCase) Then MatchCase = False
        Dim ScreenUpdating As Boolean: ScreenUpdating = Application.ScreenUpdating
        On Error GoTo ExitFunction
        Application.ScreenUpdating = False
        Dim PadLen As Long: PadLen = Len(CStr(UBound(SortArray) + 1))
        Dim Col As Range, Index As Long, i As Long, Cell As Range
        With SortRange
            Set Col = Application.Intersect(SortRange, .Columns(SortColumn))
            If Col Is Nothing Then Exit Function
            For Each Cell In Col
                Index = UBound(SortArray) + 1
                For i = 0 To UBound(SortArray)
                    If MatchCase = True Then
                        If InStr(Cell.Value, SortArray(i)) Then Index = i
                        If InStr(LCase(Cell.Value), LCase(SortArray(i))) Then Index = i
                    End If
                    If Index <> UBound(SortArray) + 1 Then Exit For
                Next i
                Cell.Value = String(PadLen - Len(CStr(Index)), "0") & Index & "#" & Cell.Value
            Next Cell
            .Cells.Sort Key1:=.Columns(SortColumn), Order1:=xlAscending, Header:=Header, MatchCase:=MatchCase
            For Each Cell In Col
                Cell.Value = Right(Cell.Value, Len(Cell.Value) - InStr(Cell.Value, "#"))
            Next Cell
        End With
        SubstringSort = True
        Application.ScreenUpdating = ScreenUpdating
    End Function
  2. 2017-01-06 17:01

    here's a proposal without helper columns:

    Option Explicit
    Sub sort()
        Dim nCustomSort As Variant, elem As Variant
        Dim LastCell As Range
        nCustomSort = Array("=*Training*", "=*Admin*", "=*General*", "=*Extra Info*") '<--| the order of appearance in this array determines the order of sorting
        Application.DisplayAlerts = False
        With Worksheets("Sheet1")
            With .Range("A1:Z" & .Cells(Rows.Count, "B").End(xlUp).Row)
                Set LastCell = .Cells(.Rows.Count, 1).Offset(1)
                For Each elem In nCustomSort
                    .AutoFilter field:=2, Criteria1:=elem
                    If Application.WorksheetFunction.Subtotal(103, .Offset(, 1).Resize(, 1)) > 1 Then
                        With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
                            .Copy LastCell
                            Set LastCell = .Parent.Cells(.Parent.Rows.Count, 2).End(xlUp).Offset(1, -1)
                        End With
                    End If
                Next elem
            End With
            .AutoFilterMode = False
        End With
        Application.DisplayAlerts = True
    End Sub

    the drawback is that copying and deleting is a time consuming operation so that if you have many k of rows it may take too long

◀ Go back