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中的数据进行排序：

空单元格
string＆＃34; XCP＆＃34;
所有其余的（从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 =表格（＆＃34; Sheet1＆＃34;）。单元格（Rows.Count，＆＃34; A＆＃34;）。结束（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

我的建议包括以下步骤：

在其中添加包含此公式的排序列：

= IF（ISBLANK（B2），1，IF（B2 = “XCP”，2,3））
在其中添加包含此公式的选定列：

= VLOOKUP（A2，A2 Sheet2的：A14,1，FALSE）
对工作表应用数据透视表。您可以使用数据透视表快速完成所需的所有切片和切块。

请注意，需要对sheet2中的引用进行排序。

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

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

2 个答案: