With VBA, how to sort data with different conditions?

Question

I would really appreciate some help to find a correct approach to solve my issue.

I need to mach data from different sheets.

In the sheet 1, I have this list of data.

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

… …

In the sheet2, I will only have the list of unique references

ID123 ID124 ID125 ...

By unique reference, I need to sort the data from the column B with the below conditions:

empty cells
string "XCP"
all the rest (from ABC to YZA)

Then, count the number of rows by unique reference Insert this number of rows in the sheet2 and paste the data sorted.

I think the easiest way to do it is to use a loop with a If statement for each of my condition instead of the sorting option.

The expected result are : So it seems to be the same as sheet 1 but col b respect my sorting conditions

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

ID124               empty cell
ID124               XCP

. Please see below the code i try to create

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

What have you tried? What were the results? This is not a code-writing service, but we will be happy to help you debug your code. See stackoverflow.com/help for information as to how to ask a good question. — Ron Rosenfeld
Thanks Ron, I will see the help on how to ask a good question. I also updated my initial question with the piece of codes I tried. I will continue to try in this direction unless I am advise that it is not the best approach. — LK.3
Record a macro while performing the task interactively, then inspect the macro. — Pieter Geerkens
@LK.3 It would be helpful if you could show what you expect for results, given the input. — Ron Rosenfeld
@RonRosenfeld I reply to your question by editing my initial question. thanks — LK.3

Ron Rosenfeld Ron Rosenfeld · Accepted Answer · 2014-08-18T11:57:48

Assuming the ellipsis is not really going to be there, and using VBA, I would suggest the following:

Add a custom list consisting of a "throwaway character" (I use ASCII 1 for that) and XCP
Copy the table from sheet1 (the source) to sheet3 (the results)
Replace the blanks with ASCII 1 (as you really can't make Excel sort blanks to the top)
Sort by the KEY and then by the second column using our custom list for the sort order
Remove the ASCII 1
Add in the blank rows between the different sets of ID's

Here is the code:

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

You may want to turn off screenupdating to save time or reduce flicker, once things are working properly.

With VBA, how to sort data with different conditions?

2 Answers