Question

我是VBA的新手，希望能得到一些关于排序和订购的指导。

我有一个包含大约200行和5列的信息表。在B列中有“附加信息”，我希望确定哪些行的文本部分包含以下任何一个词：“Training”，“Admin”，“General”和“Extra Info”并将它们组合在一起

所以一个例子是：个人管理员，工作管理员，重量训练， DD Extra Info， 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

缺点是复制和删除是一项耗时的操作，所以如果你有很多行的行，可能需要很长时间

使用VBA根据单元格中的非精确值对列表进行排序

2 个答案: