VBA: special alphabetical order

[Nelson78]

Hello everybody.

I'm struggling in order to build a code for an unconventional alphabetical order.

Consider I have the record from row 2 to n in a randomic order.

In the image the requested outcome.

https://imgur.com/a/j0Jv1Cs

The principles:
1) Surname's sellers - yellow rows - in alphabetical order;
2) then, for each seller, the related white rows (see the code in column B) in alphabetical order for column A.

I think it is not possible to figure it out with the conventional Excel settings.

Any idea?

Thank's for the support.

 

[Nelson78]

You are using all 16,000+ columns on the worksheet?

In theory yes (consider that on row 1 dates are set, and for each date the related quantity of each item).
Anyway, put in practical terms, it is highly unlikely.

 

[Nelson78]

Its simple with a helper column or its going to need more complex coding than i can muster at the moment. Is column D available to use as a helper?

My boss' request has undermined even the greatest Excel maestros

 

[Nelson78]

Its simple with a helper column or its going to need more complex coding than i can muster at the moment. Is column D available to use as a helper?

Nothing smarter then this (with one helper).

Sub alphabetic()

Dim lr As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row

Dim nr As Integer

'define helper column
Range("D1") = "Helper"

'if "head row" then report code on helper
For Each ThisCell In Range("B2:B" & lr)
    If ThisCell.Interior.Color = RGB(255, 255, 0) Then
        ThisCell.Offset(0, 2) = ThisCell
    End If
Next ThisCell

'if not "head row" then report seller on helper by capturing row number
For Each thiscell2 In Range("B2:B" & lr)
    If thiscell2.Interior.Color <> RGB(255, 255, 0) Then
        nr = Range("D2:D" & lr).Find(thiscell2).Row
        thiscell2.Offset(0, 2).Value = Range("A" & nr)
    End If
Next thiscell2

'redefine helper in concatenating information and preserving "head row" by "cutting" the last information
For Each thiscell3 In Range("D2:D" & lr)
    If thiscell3.Offset(0, -1).Interior.Color = RGB(255, 255, 0) Then
        thiscell3.Value = thiscell3.Offset(0, -3) & thiscell3.Offset(0, -2)
    Else
        thiscell3.Value = thiscell3 & thiscell3.Offset(0, -2) & thiscell3.Offset(0, -3)
    End If
Next thiscell3
        
'define entire sheet to sort
Set Rngsort = Worksheets("Sheet 1").UsedRange

'define key
Set RngKey = Worksheets("Sheet 1").Range("D1")

'sort for defined key
With Worksheets("Sheet 1").Sort
    Rngsort.Sort Key1:=RngKey, Order1:=xlAscending, Header:=xlYes, MatchCase:=False, Orientation:=xlSortColumns
End With

'clear helper
Range("D1:D" & lr).Clear

End Sub

 

[shg]

Sub nelson()
  Dim iRow          As Long
  Dim sName         As String

  Range("A:B").Insert
  For iRow = 2 To Cells(Rows.Count, "C").End(xlUp).Row
    With Rows(iRow)
      If .Range("C1").Interior.Color = vbYellow Then
        sName = .Range("C1").Value
        .Range("A1:B1").Value = Array(sName, sName)
      Else
        .Range("A1:B1").Value = Array(sName, "zzz")
      End If
    End With
  Next iRow

  Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Key2:=Range("B1"), Header:=xlYes
  Range("A:B").Delete
End Sub

 

[Peter_SSs]

This uses no extra columns, see if it does what you want. Test in a copy of your workbook.

Sub Special_Sort()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  With Range("A2", Range("C" & Rows.Count).End(xlUp))
    a = .Value
    For i = 1 To UBound(a)
      Select Case a(i, 1)
        Case "NEGOTIATING", "NOT SOLD", "SOLD"
        Case Else
          d(a(i, 2)) = a(i, 1)
      End Select
    Next i
    For i = 1 To UBound(a)
      Select Case a(i, 1)
        Case "NEGOTIATING", "NOT SOLD", "SOLD"
          a(i, 2) = d(a(i, 2)) & "-" & a(i, 1) & "-" & a(i, 2)
        Case Else
          a(i, 2) = d(a(i, 2)) & "-A-" & a(i, 2)
      End Select
    Next i
    Application.ScreenUpdating = False
    .Value = a
    .Sort Key1:=.Columns(2), Order1:=xlAscending, Header:=xlNo
    .Columns(2).Replace What:="*-", Replacement:="", LookAt:=xlPart
    Application.ScreenUpdating = True
  End With
End Sub

 

[Nelson78]

Sub nelson()
  Dim iRow          As Long
  Dim sName         As String

  Range("A:B").Insert
  For iRow = 2 To Cells(Rows.Count, "C").End(xlUp).Row
    With Rows(iRow)
      If .Range("C1").Interior.Color = vbYellow Then
        sName = .Range("C1").Value
        .Range("A1:B1").Value = Array(sName, sName)
      Else
        .Range("A1:B1").Value = Array(sName, "zzz")
      End If
    End With
  Next iRow

  Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Key2:=Range("B1"), Header:=xlYes
  Range("A:B").Delete
End Sub

With two helpers.
Fine, it works.

 

[Nelson78]

This uses no extra columns, see if it does what you want. Test in a copy of your workbook.

Sub Special_Sort()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  With Range("A2", Range("C" & Rows.Count).End(xlUp))
    a = .Value
    For i = 1 To UBound(a)
      Select Case a(i, 1)
        Case "NEGOTIATING", "NOT SOLD", "SOLD"
        Case Else
          d(a(i, 2)) = a(i, 1)
      End Select
    Next i
    For i = 1 To UBound(a)
      Select Case a(i, 1)
        Case "NEGOTIATING", "NOT SOLD", "SOLD"
          a(i, 2) = d(a(i, 2)) & "-" & a(i, 1) & "-" & a(i, 2)
        Case Else
          a(i, 2) = d(a(i, 2)) & "-A-" & a(i, 2)
      End Select
    Next i
    Application.ScreenUpdating = False
    .Value = a
    .Sort Key1:=.Columns(2), Order1:=xlAscending, Header:=xlNo
    .Columns(2).Replace What:="*-", Replacement:="", LookAt:=xlPart
    Application.ScreenUpdating = True
  End With
End Sub

Something seems wrong at the end of elaborations, because the seller's name has to be on top and alphabetical order:

Seller code quantity
sold abcd004 3
callagher abcd004 12
negotiating abcd004 5
not sold abcd004 4
smith abcd001 15
negotiating abcd001 3
not sold abcd001 7
sold abcd001 5
brown abcd002 20
negotiating abcd002 2
not sold abcd002 10
sold abcd002 8
gray abcd003 22
negotiating abcd003 10
not sold abcd003 2
sold abcd003 10



Furthermore, the cases could not be limited to NEGOTIATING, NOT SOLD and SOLD (that is a field that could be filled manually by an user without constraints, so tomorrow he could write, for instance, SUSPENDED ).

 

[Peter_SSs]

Something seems wrong ...

That is because your sample data has changed from upper case in your original image to lower case in your latest samples. That could easily be fixed.
However, that would not solve the following problem - which we didn't know about until now. (We can only use the information you give us!). Sample data needs to be representative.

Furthermore, the cases could not be limited to NEGOTIATING, NOT SOLD and SOLD (that is a field that could be filled manually by an user without constraints, so tomorrow he could write, for instance, SUSPENDED ).

Try this then

Sub Special_Sort_v2()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  With Range("A2", Range("C" & Rows.Count).End(xlUp))
    a = .Value
    For i = 1 To UBound(a)
      If d.exists(a(i, 2)) Then
        If a(i, 3) > Val(Split(d(a(i, 2)), "|")(1)) Then d(a(i, 2)) = a(i, 1) & "|" & a(i, 3)
      Else
        d(a(i, 2)) = a(i, 1) & "|" & a(i, 3)
      End If
    Next i
    For i = 1 To UBound(a)
      a(i, 1) = d(a(i, 2)) & IIf(CStr(a(i, 3)) = Split(d(a(i, 2)), "|")(1), "0-", "1-") & a(i, 1)
    Next i
    Application.ScreenUpdating = False
    .Value = a
    .Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlNo
    .Columns(1).Replace What:="*-", Replacement:="", LookAt:=xlPart
    Application.ScreenUpdating = True
  End With
End Sub

 

[Nelson78]

That is because your sample data has changed from upper case in your original image to lower case in your latest samples. That could easily be fixed.
However, that would not solve the following problem - which we didn't know about until now. (We can only use the information you give us!). Sample data needs to be representative.

Yes, I'm sorry, you are completely right.

The problem is I've been dealing with a lot of data (most of them private), so I've to balance on one side the need of sharing with you all the relevant features, on the other side the need of being as synthetic as possible.

Anyway, my goal will be to be more exhaustive.

 

[Peter_SSs]

So how did the new code in post 18 go?