使用VBA根據單元格中的非精確值排序列表

Question

我是VBA的新手，希望能獲得有關排序和排序的指導。

我有一張約200行5列的信息表。 在B列中有“其他信息”，我想確定哪些行的文本部分包含以下任何一個單詞：“培訓”，“管理員”，“常規”和“其他信息”，並將它們分組在一起。

因此，一個例子是：個人管理員，工作管理員，體重訓練，DD額外信息，EAS訓練，一般寫作。

因此，我需要能夠僅根據每個單元格值的一部分對整個行進行排序和排序。

希望有道理-非常感謝您的指導！

我過去曾使用此自定義列表來查找和排序確切的短語：

Dim nCustomSort As Variant
Dim xx As Long

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

Application.AddCustomList ListArray:=nCustomSort

With Worksheets("Sheet1")
.Sort.SortFields.Clear
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
  .Sort.SortFields.Clear
End With

Answer 1

據我所知，您不能在自定義列表中使用通配符對數據進行排序。

下面的代碼顯示了一個通用的子字符串排序功能，該功能允許區分大小寫和擴展的子字符串數組進行測試。

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
                Else
                    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

ExitFunction:
    Application.ScreenUpdating = ScreenUpdating
End Function

Answer 2

這是沒有助手列的提案：

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)
                        .Delete
                    End With
                End If
            Next elem
        End With
        .AutoFilterMode = False
    End With
    Application.DisplayAlerts = True
End Sub

缺點是復制和刪除是一項耗時的操作，因此，如果您有很多k行，可能會花費很長時間