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

我真的很感谢帮助find一个正确的方法来解决我的问题。

我需要从不同的工作表。

在表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 …

通过独特的参考，我需要sorting列B的数据与下面的条件：

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

然后，通过唯一引用对行数进行计数在工作表2中插入此行数并粘贴数据。

我认为最简单的方法是使用一个带有If语句的循环来代替sorting选项。

预期的结果是：所以它似乎是与表1相同，但上下文尊重我的分拣条件

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

。 请参阅下面的代码，我尝试创build

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，我会build议如下：

• 添加一个由“一次性字符”（我使用ASCII 1）和XCP组成的自定义列表
• 将sheet1（源文件）中的表复制到sheet3（结果）
• 用ASCII 1replace空格（因为你真的不能使Excelsorting空白到顶部）
• 按照KEYsorting，然后按照sorting顺序的自定义列表按第二列sorting
• 删除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 

一旦正常工作，您可能需要closuresscreenupdating以节省时间或减less闪烁。

Answer 2

我的build议包括以下步骤：

1. 在这个公式中添加一个sorting列：

   = IF（ISBLANK（B2），1，IF（B2 = “XCP”，2,3））

2. 用这个公式添加一个选定的列：

   = VLOOKUP（A2，Sheet2的A2：A14,1，FALSE）

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

请注意sheet2中的引用需要sorting。

还要注意，这个build议不需要vba。