Manual sort macro

[smpita]

Thank you for your attention to my thread.

I have spreadsheet that I have to sort the rows in. I have already recorded an autosort to put the spreadsheet into alphabetical format but I need a slight modification of the sort. The spreadsheet is not very long so it shouldn't be much issue to sort it twice unless you know of a better way.

Here is a sample that shows what a typical spreadsheet might look like.
spreadsheet.png

What I need is a way to move the MN and URS rows to the top of the list. In this case, it would end up in an order similar to this:

MN 12345
MN 123456
URS 23456
URS 234567
ARB 123A
WRD 1234

It does not matter which of MN or URS is at the top, but MN needs to stay grouped together as does URS. I already have the following code cycling through the rows.

    Dim groupMN As Single
    Dim groupURS As Single
    Dim groupOther As Single
    Dim lastMN As Integer
    Dim lastURS As Integer
    Dim lastOther As Integer
    Dim cell As Range
    
    For Each cell In Range("A2:A" & Range("A1").CurrentRegion.Rows.Count)
        If Left(cell, 2) = "MN" Then
            If ExtractElement(cell, 2, " ") < 200001 Then GoTo BadCCEntry
            groupMN = groupMN + cell.Offset(, 4).Value
            lastMN = cell.Row
            GoTo GoodCCEntry
        ElseIf Left(cell, 3) = "URS" Then
            If ExtractElement(cell, 2, " ") < 10001 Or ExtractElement(cell, 2, " ") > 200000 Then GoTo BadCCEntry
            groupURS = groupURS + cell.Offset(, 4).Value
            lastURS = cell.Row
            GoTo GoodCCEntry
        Else
            If Not Val(ExtractElement(cell, 2, " ")) < 9999 Then GoTo BadCCEntry
            groupOther = groupOther + cell.Offset(, 4).Value
            lastOther = cell.Row
            GoTo GoodCCEntry
            
BadCCEntry:
    MsgBox "Account name/number mismatch. Check account numbers and subtotal manually."
GoTo VeryEnd
GoodCCEntry:
        End If
    Next cell

Thank you so much!

[stanleydgromjr]

smpita,

You are posting a picture. This means that if this was a problem where one needed to use your data, anyone trying to help you would have to enter the data manually. That makes no sense.

To get the most precise answer, it is best to upload/attach a sample workbook (sensitive data scrubbed/removed/changed) that contains an example of your raw data on one worksheet, and on another worksheet your desired results.

The structure and data types of the sample workbook must exactly duplicate the real workbook. Include a clear and explicit explanation of your requirements.

To attach your workbook, scroll down and click on the Go Advanced button, then scroll down and click on the Manage Attachments button.

[protonLeah]

Option Explicit
Sub Macro1()
    Dim lr As Long, SortList As String
    With Sheets("sheet1")
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        SortList = .Range("A2:A" & lr).Address(0, 0)
    End With
        
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add _
        Key:=Range(SortList), _
        SortOn:=xlSortOnValues, _
        Order:=xlAscending, _
        CustomOrder:="MN,URS,ARB,WRD", _
        DataOption:=xlSortNormal
        
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range(SortList)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

[smpita]

Attached (rawsortexample.csv) is a spreadsheet that needs to be custom sorted by my VBA macro. Post macro, it should look like sortexampledone.csv

In column B, you see several different values in the format "Community" (URS, MN, ARB, etc) then an "Account number" (1234a, etc) then a date. I need to sort it so that the URS and MN communities are on top and everything else is on the bottom. My example shows ARB, CM and WRD communities but we are often adding new communities so I can't use the CustomOrder: method suggested by protonLeah above as we would need to be constantly updating the macro to include new communities. I was thinking something to the effect of pseudocode:

   For Each cell In Range("A2:A" & Range("A1").CurrentRegion.Rows.Count)
        If Left(cell, 2) = "MN" Then
           Move cell.row to row.2
        ElseIf Left(cell, 3) = "URS" Then
           Move cell.row to row.2
        Endif
   Next cell

The communities will already be sorted by the following code and be in alphabetical order. I just need to move the URS and MN accounts to the top of the pile somehow.

    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add _
        Key:=Range("B2:B" & Lrow), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:J" & Lrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Here is the part of my macro that deals with this report in full.

Dim Lrow As Long

    With ActiveSheet.UsedRange
        Lrow = .Cells(.Cells.Count).Row - 4
    End With
    
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add _
        Key:=Range("B2:B" & Lrow), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:J" & Lrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Columns("K").Delete
    Columns("A").Delete
    Columns("C:F").Delete
    Columns("A").ColumnWidth = 12
    Columns("B").ColumnWidth = 14.5
    Columns("C").ColumnWidth = 24.5

    Dim groupMN As Single
    Dim groupURS As Single
    Dim groupOther As Single
    Dim lastMN As Integer
    Dim lastURS As Integer
    Dim lastOther As Integer
    Dim cell As Range
    
    For Each cell In Range("A2:A" & Range("A1").CurrentRegion.Rows.Count)
        If Left(cell, 2) = "MN" Then
            If ExtractElement(cell, 2, " ") < 200001 Then GoTo BadCCEntry
            groupMN = groupMN + cell.Offset(, 4).Value
            lastMN = cell.Row
            GoTo GoodCCEntry
        ElseIf Left(cell, 3) = "URS" Then
            If ExtractElement(cell, 2, " ") < 10001 Or ExtractElement(cell, 2, " ") > 200000 Then GoTo BadCCEntry
            groupURS = groupURS + cell.Offset(, 4).Value
            lastURS = cell.Row
            GoTo GoodCCEntry
        Else
            If Not Val(ExtractElement(cell, 2, " ")) < 9999 Then GoTo BadCCEntry
            groupOther = groupOther + cell.Offset(, 4).Value
            lastOther = cell.Row
            GoTo GoodCCEntry
            
BadCCEntry:
    MsgBox "Account name/number mismatch. Check account numbers and subtotal manually."
GoTo VeryEnd
GoodCCEntry:
        End If
    Next cell
    
    If groupMN > 0 Then Range("F" & lastMN).Value = groupMN
    If groupURS > 0 Then Range("F" & lastURS).Value = groupURS
    If groupOther > 0 Then Range("F" & lastOther).Value = groupOther
GoTo VeryEnd

[shg]

You could use a two-column lookup table with communities on the left column and sort order on the right, and then use a lookup formula in a convenient column. Sort on that.

[smpita]

shg - I'm not sure I know what you meant but this is what I came up with from your suggestion. It seems to work, but I'm not sure if it's the most efficient code. Thank you!

    For Each cell In Range("A2:A" & Range("A1").CurrentRegion.Rows.Count)
        If Left(cell, 2) = "MN" Then
            If ExtractElement(cell, 2, " ") < 200001 Then GoTo BadCCEntry
            groupMN = groupMN + cell.Offset(, 4).Value
            lastMN = cell.Row
            cell.Offset(, 6).FormulaR1C1 = "1"
            GoTo GoodCCEntry
        ElseIf Left(cell, 3) = "URS" Then
            If ExtractElement(cell, 2, " ") < 10001 Or ExtractElement(cell, 2, " ") > 200000 Then GoTo BadCCEntry
            groupURS = groupURS + cell.Offset(, 4).Value
            lastURS = cell.Row
            cell.Offset(, 6).FormulaR1C1 = "2"
            GoTo GoodCCEntry
        Else
            If Not Val(ExtractElement(cell, 2, " ")) < 9999 Then GoTo BadCCEntry
            groupOther = groupOther + cell.Offset(, 4).Value
            lastOther = cell.Row
            cell.Offset(, 6).FormulaR1C1 = "3"
            GoTo GoodCCEntry
            
BadCCEntry:
    MsgBox "Account name/number mismatch. Check account numbers and subtotal manually."
GoTo VeryEnd
GoodCCEntry:
        End If
    Next cell
    
    If groupMN > 0 Then Range("F" & lastMN).Value = groupMN
    If groupURS > 0 Then Range("F" & lastURS).Value = groupURS
    If groupOther > 0 Then Range("F" & lastOther).Value = groupOther

    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add _
        Key:=Range("G2:G" & Lrow), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:G" & Lrow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Columns("G").Delete

GoTo VeryEnd

[shg]

Using code for this lacks flexibility and is overkill. I had in mind just a table and a formula:

	A	B	C	D	E	F	G	H
1	Comm	Acct	Date	Sort			Comm	Order
2	MN			2	D2: =IFERROR(VLOOKUP(A2, $G$2:$H$4, 2, 0), 99)		URS	1
3	URS			1			MN	2
4	XXX			99			ARB	3
5	MN			2
6	XXX			99
7	XXX			99
8	URS			1
9	XXX			99
10	MN			2
11	ARB			3
12	MN			2