使用VBA，如何对不同条件的数据进行排序？

Question

如果能帮助我找到解决问题的正确方法，我将不胜感激。

我需要从不同的工作表中处理数据。

在表格 1 中，我有这个数据列表。

Key Reference      COL B          COL C      COL D
ID123                YZA              ...        ...
ID123                BBA              ...        ... 
ID123                XCP              ...        ... 
ID123                ABC
ID123                empty cell
ID123                …
 
ID124               empty cell
ID124               XCP

… …

在 sheet2 中，我将只有唯一引用列表

ID123
ID124
ID125

...

通过唯一引用，我需要使用以下条件对 B 列中的数据进行排序：

1. 空单元格
2. 字符串“XCP”
3. 其余所有（从 ABC 到 YZA）

然后，通过唯一引用计算行数 在 sheet2 中插入此行数 并粘贴已排序的数据。

我认为最简单的方法是对我的每个条件使用带有 If 语句的循环，而不是排序选项。

预期结果是：所以它似乎与表 1 相同，但 col b 尊重我的排序条件

Key Reference        COL B          COL C      COL D
ID123                empty cell       ...        ...
ID123                XCP              ...        ... 
ID123                ABC
ID123                YZA
ID123                …
 
ID124               empty cell
ID124               XCP

请看下面我尝试创建的代码

Sub mapbreak5()
    Dim lr As Long, r As Long
    lr = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    Dim rngKey As Range
    
    For r = 2 To lr
    If Sheets("Sheet1").Range("B" & r).Value = "" Then
    '...
    End If
    Next r
    'Or =>
    
    Do
    If Range("B2") Is Empty Then
    Copy.EntireRow
        'find the respective key refence in the breaks sheet
        ThisWorkbook.Worksheets("breaks").Cells.Find(rngKey.Value, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            'check if the IDxx field is already populated
            If Range("F2") Is Empty Then
            Range("E2").Paste.Selection
            Else: ActiveCell.Offset (1)
            Rows.Select
            Selection.Insert Shift:=xlDown
            End If
        Else: ActiveCell.Offset (1)
        End If
    Loop Until IsEmpty(ActiveCell.Offset(0, -1))
    
    Do
        If Range("B2") = "XCP" Then
        Copy.EntireRow
        'find the respective key refence in the breaks sheet
        ThisWorkbook.Worksheets("breaks").Cells.Find(rngKey.Value, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            'check if the IDxx field is already populated
            If Range("F2") Is Empty Then
            Range("E2").Paste.Selection
            Else: ActiveCell.Offset (1)
            Rows.Select
            Selection.Insert Shift:=xlDown
            End If
        Else: ActiveCell.Offset (1)
        End If
    Loop Until IsEmpty(ActiveCell.Offset(0, -1))

    Do
        If Range("B2") Is Not Empty Or "XCP" Then
        Copy.EntireRow
        'find the respective key refence in the breaks sheet
        ThisWorkbook.Worksheets("breaks").Cells.Find(rngKey.Value, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            'check if the IDxx field is already populated
            If Range("F2") Is Empty Then
            Range("E2").Paste.Selection
            Else: ActiveCell.Offset (1)
            Rows.Select
            Selection.Insert Shift:=xlDown
            End If
        Else: ActiveCell.Offset (1)
        End If
    Loop Until IsEmpty(ActiveCell.Offset(0, -1))

End Sub

Answer 1

假设省略号真的不存在，并且使用 VBA，我建议如下：

• 添加一个由“一次性字符”（我为此使用 ASCII 1）和 XCP 组成的自定义列表
• 将表格从 sheet1（源）复制到 sheet3（结果）
• 用 ASCII 1 替换空格（因为你真的不能让 Excel 将空格排序到顶部）
• 按 KEY 排序，然后使用我们的自定义列表按第二列排序
• 删除 ASCII 1
• 在不同的 ID 集之间添加空白行

代码如下：

Option Explicit
Sub CopyAndCustomSort()
    Dim wsSRC As Worksheet, wsRES As Worksheet
    Dim rSRC As Range, rRES As Range, rSORT As Range
    Dim vSRC As Variant, vSORT As Variant
    Dim arrCustomList As Variant
    Dim lListNum As Long
    Dim I As Long

Set wsSRC = Worksheets("Sheet1")
Set wsRES = Worksheets("Sheet3")

With wsSRC
    Set rSRC = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(columnsize:=2)
End With

Set rRES = wsRES.Range("A1")

'Add custom list with chr(1) for blanks sorting
arrCustomList = Array(Chr(1), "XCP")
lListNum = Application.GetCustomListNum(arrCustomList)
If lListNum = 0 Then
    Application.AddCustomList arrCustomList
    lListNum = Application.CustomListCount
End If

'Replace blanks with chr(1)
vSRC = rSRC
For I = 1 To UBound(vSRC, 1)
    If vSRC(I, 1) <> "" And vSRC(I, 2) = "" Then vSRC(I, 2) = Chr(1)
Next I

'copy list to destination
wsRES.Cells.Clear
Set rRES = rRES.Resize(UBound(vSRC, 1), UBound(vSRC, 2))
rRES = vSRC

'custom sort
Set rSORT = rRES.Offset(1, 0).Resize(rRES.Rows.Count - 1)
With wsRES.Sort.SortFields
    .Clear
    .Add Key:=rSORT.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    .Add Key:=rSORT.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, _
        CustomOrder:=lListNum, DataOption:=xlSortNormal
End With
With wsRES.Sort
    .SetRange rRES
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .Apply
End With

'Remove the chr(1)
'For some reason, the replace method with this character replaces everything
vSORT = rSORT.Columns(2)
For I = 1 To UBound(vSORT, 1)
    If vSORT(I, 1) = Chr(1) Then vSORT(I, 1) = ""
Next I
rSORT.Columns(2) = vSORT

'Insert blank row after each ID change
For I = rRES.Rows.Count To 3 Step -1
    If rRES(I, 1) <> rRES(I - 1, 1) Then
        rRES.Rows(I).Insert shift:=xlDown
    End If
Next I

End Sub

一旦一切正常，您可能想要关闭屏幕更新以节省时间或减少闪烁。

Answer 2

我的建议包括以下步骤：

1. 添加一个包含此公式的排序列：

   =IF(ISBLANK(B2),1,IF(B2="XCP",2,3))

2. 添加一个包含此公式的选定列：

   =VLOOKUP(A2,Sheet2!A2:A14,1,FALSE)

3. 对工作表应用数据透视表。您可以使用数据透视表快速完成所有需要的切片和切块。

注意，sheet2中的引用需要排序。

另请注意，此建议不需要 vba。