Creating a Multi-column sort that also adds a line between different items

K

kgeetings

New Member
Joined
Oct 13, 2021
Messages
9
Office Version
  1. 365
Platform
  1. Windows
So I've got a start on the code to sort a list of materials where I can enter the materials how I want (seen here) and then it will sort to the correct way as seen in the second picture.
BeforeSortExample.png


Where I've got the "Let the Magic Happen v2" button to automatically sort the list to the way I want it, but I want to then add a new line (that is also still formatted with the boxes and formulas) like this:
FinalExample.png


This is my current code, but I'm stuck on how to add a "blank" line in between the different materials/sizes:
VBA Code: 
Private Sub Let_The_Magic_Happen_v2_Click()
Application.ScreenUpdating = False
    ' Sorts the worksheet
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("J35:J" & Cells(Rows.Count, "J").END(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "HRT,LASER,DELRIN,HDPE,8#XLPE", DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("L35:L" & Cells(Rows.Count, "J").END(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("M35:M" & Cells(Rows.Count, "J").END(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("N35:N" & Cells(Rows.Count, "J").END(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("O35:O" & Cells(Rows.Count, "J").END(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= xlSortNormal
    With ActiveWorkbook.Worksheets("Quote_and_Cut").Sort
        .SetRange Range("A35:W" & Cells(Rows.Count, "J").END(xlUp).Row)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply

    ' Fixes the Cut List Subtotal SUM, because Excel tries to change it during sort (this part isn't really too relevant to this post, but wanted to include it just in case)
    Dim ThisPos As Range
        With Range("U1:U32000")
            Set ThisPos  = .Find(What:="CUT LIST SUBTOTAL", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
            If Not ThisPos  Is Nothing Then
                Cell_Add= Split(ThisPos.Address, "$")
                ThisRow = Cell_Add(1)
                ThisCol = Cell_Add(2)
                ActiveWorkbook.Worksheets("Quote_and_Cut").Range("W" & ThisCol).Value = "=SUM(W35:W" & (ThisCol - 1) & ")"
            Else
                msgboxresponse = MsgBox("CUT LIST SUBTOTAL not found")
            End If
        End With
Application.ScreenUpdating = True
End With
End Sub

I appreciate any help that you can provide, thanks!
 
Sort by date Sort by votes
Alex Blakenburg said:
OK a couple of changes.
The overflow error you are trapping shouldn't happen if you change these 2 that are currently integer.
VBA Code: 
Dim counter as long, EndCount as long

This currently used line used in a number of places doesn't work. All it needs to do is to work out the last row.
It is counting constant values which means eventhough the code is redoing it after inserting each blank row, blank rows are not being counted so the number is not increasing after every insert.
Currently
VBA Code: 
        With Worksheets("Quote_and_Cut").Columns("J").SpecialCells(xlCellTypeConstants)
            EndCount = .Cells(.Cells.Count).Row
        End With

You wold be better off with this.
You can either keep checking this on just go EndCount = EndCount + 1
every time you insert a row.
VBA Code: 
EndCount = Worksheets("Quote_and_Cut").Cells(Rows.Count, "J").End(xlUp).Row


View attachment 49108
Click to expand...
Thanks for the tips, I haven't gotten a chance to try to implement this yet, but one concern I have is that row J actually always has a formula in it that actually pulls from a metric sheet if I need a conversion from metric of imperial, like shown here:
MetricToImperial.png

Will that cause issues then?
 
Upvote 0

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off
Ok, so I haven't had a chance to test everything yet, but I've modified my code to still use my EndCount with the constants, but I also now increase the EndCount when adding a new line, and it appears to work fine for the few tests I've been able to run.
VBA Code: 
Private Sub Let_The_Magic_Happen_v2_Click()
Application.ScreenUpdating = False
    ' Sorts the worksheet
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("J35:J" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "HRT,HRTRND,HRA,HRCNL,HRRND,HRFLT,HRSHT,CFRND,CFFLT,ALT,ALTRND,ALA,ALCNL,ALRND,ALFLT,SSRND,SSA,SSFLT,SSSHT,LASER,DELRIN,NYLON,HDPE,UMHW,8#XLPE,MISC", DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("L35:L" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("M35:M" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("N35:N" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("O35:O" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Quote_and_Cut").Sort
        .SetRange Range("A35:W" & Cells(Rows.Count, "J").End(xlUp).Row)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
End With
'Removes the extra rows at the end of the cut sheet, as they are not needed (but leave two extra rows at the bottom for looks)
With Worksheets("Quote_and_Cut").Columns("J").SpecialCells(xlCellTypeConstants)
        Lastrow1 = .Cells(.Cells.Count).Row
End With
Dim EndOfCut As Range
    With Range("U1:U32000")
        Set EndOfCut = .Find(What:="CUT LIST SUBTOTAL", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not EndOfCut Is Nothing Then
            Cell_Add = Split(EndOfCut.Address, "$")
            ThisRow = Cell_Add(1)
            ThisCol = Cell_Add(2)
            If ((ThisCol - 1) - (Lastrow1 + 1)) > 3 Then
                Rows((Lastrow1 + 3) & ":" & (ThisCol - 1)).EntireRow.Delete
            End If
        Else
            msgboxresponse = MsgBox("CUT LIST SUBTOTAL not found")
        End If
    End With
'Removes all the rows below the last data in W because like why are they there.
'Dim bottomrow, lastblank as long
'    Bottomrow = ActiveSheet.UsedRange.Rows.Count
'    lastblank = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
'    Range("W" & Lastblank & "W" & Bottomrow).EntireRow.Delete
'Scrolls through the list and inserts a line between different materials
    With Range("J35").Select
        Dim counter As long
        counter = 35
        mtlname = "a"
        mtlname2 = "a"
        Dim EndCount As long
        With Worksheets("Quote_and_Cut").Columns("J").SpecialCells(xlCellTypeConstants)
            EndCount = .Cells(.Cells.Count).Row
        End With
    Do While counter < EndCount
        softEnd0:
        mtlname = "a"
        mtlname2 = "a"
        Do While (mtlname = mtlname2)
            If counter >= EndCount Then 
                GoTo hardEnd0
            Else
                mtlname = Cells(counter, 10)
                counter = counter + 1
                mtlname2 = Cells(counter, 10)
            End If
        Loop
        With Sheets("Quote_and_Cut")
            If mtlname2 = "" Then
                counter = counter + 1
                GoTo softEnd0
            Else
                .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
                Selection.Insert shift:=xlDown
                counter = counter + 1
                EndCount = EndCount + 1
            End If
        End With
    hardEnd0:
    Loop

'Scrolls through the list and inserts a line between different DIM1
    With Range("L35").Select
        counter = 35
        dim1name = "0"
        dim1name2 = "0"
        With Worksheets("Quote_and_Cut").Columns("J").SpecialCells(xlCellTypeConstants)
            EndCount = .Cells(.Cells.Count).Row
        End With
    Do While counter < EndCount
        softEnd1:
        dim1name = "0"
        dim1name2 = "0"
        Do While (dim1name = dim1name2)
            If counter >= EndCount Then 
                GoTo hardEnd1
            Else
                dim1name = Cells(counter, 12)
                counter = counter + 1
                dim1name2 = Cells(counter, 12)
            End If
        Loop
        With Sheets("Quote_and_Cut")
            If Cells(counter, 10) = "" Or Cells(counter -1, 10) = "" Then
                counter = counter + 1
                GoTo softEnd1
            Else
                .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
                Selection.Insert shift:=xlDown
                counter = counter + 1
                EndCount = EndCount + 1
            End If
        End With
    Loop
    hardEnd1:  
    End With
'Scrolls through the list and inserts a line between different DIM2
    With Range("M35").Select
        counter = 35
        dim2name = "0"
        dim2name2 = "0"
        With Worksheets("Quote_and_Cut").Columns("J").SpecialCells(xlCellTypeConstants)
            EndCount = .Cells(.Cells.Count).Row
        End With
    Do While counter < EndCount
        softEnd2:
        dim2name = "0"
        dim2name2 = "0"
        Do While (dim2name = dim2name2)
            If counter >= EndCount Then 
                GoTo hardEnd2
            Else
                dim2name = Cells(counter, 13)
                counter = counter + 1
                dim2name2 = Cells(counter, 13)
            End If
        Loop
        With Sheets("Quote_and_Cut")
            If Cells(counter, 10) = "" Or Cells(counter -1, 10) = "" Then
                counter = counter + 1
                GoTo softEnd2
            Else
                .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
                Selection.Insert shift:=xlDown
                counter = counter + 1
                EndCount = EndCount + 1
            End If
        End With
    Loop
    hardEnd2:  
    End With
'Scrolls through the list and inserts a line between different DIM3
    With Range("N35").Select
        counter = 35
        dim3name = "0"
        dim3name2 = "0"
        With Worksheets("Quote_and_Cut").Columns("J").SpecialCells(xlCellTypeConstants)
            EndCount = .Cells(.Cells.Count).Row
        End With
    Do While counter < EndCount
        softEnd3:
        dim3name = "0"
        dim3name2 = "0"
        Do While (dim3name = dim3name2)
            If counter >= EndCount Then 
                GoTo hardEnd3
            Else
                dim3name = Cells(counter, 14)
                counter = counter + 1
                dim3name2 = Cells(counter, 14)
            End If
        Loop
        With Sheets("Quote_and_Cut")
            If Cells(counter, 10) = "" Or Cells(counter -1, 10) = "" Then
                counter = counter + 1
                GoTo softEnd3
            Else
                .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
                Selection.Insert shift:=xlDown
                counter = counter + 1
                EndCount = EndCount + 1
            End If
        End With
    Loop
    hardEnd3:  
    End With
    ' Fixes the Cut List Subtotal SUM, because Excel tries to change it during sort
    Dim ThisPos As Range
        With Range("U1:U32000")
            Set ThisPos = .Find(What:="CUT LIST SUBTOTAL", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
            If Not ThisPos Is Nothing Then
                Cell_Add = Split(ThisPos.Address, "$")
                ThisRow = Cell_Add(1)
                ThisCol = Cell_Add(2)
                ActiveWorkbook.Worksheets("Quote_and_Cut").Range("W" & ThisCol).Value = "=SUM(W35:W" & (ThisCol - 1) & ")"
            Else
                msgboxresponse = MsgBox("CUT LIST SUBTOTAL not found")
            End If
        End With
Application.ScreenUpdating = True
End With
End Sub

Something that I don't think is terribly important, is that I have noticed if I hit the button several times, the rows appear to change heights, and the scroll bar on the right showing my location in the sheet gets smaller every time. I think this has to do with inserting new lines? But I'm not sure if there's anything that can be done about that (or if it's even important).
 
Upvote 0
So I took more of your advice and switched the lastrow code to actually look for the last row with data (that's not a formula) and I ended up with this.
VBA Code: 
' Version Number: v2.1.1
Private Sub Let_The_Magic_Happen_v2_Click()
Application.ScreenUpdating = False
'Sorts the worksheet
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("J35:J" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
    "HRT,HRTRND,HRA,HRCNL,HRRND,HRFLT,HRSHT,CFRND,CFFLT,ALT,ALTRND,ALA,ALCNL,ALRND,ALFLT,SSRND,SSA,SSFLT,SSSHT,LASER,DELRIN,NYLON,HDPE,UMHW,8#XLPE,MISC", DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("L35:L" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("M35:M" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("N35:N" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Quote_and_Cut").Sort.SortFields.Add2 Key:=Range("O35:O" & Cells(Rows.Count, "J").End(xlUp).Row), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Quote_and_Cut").Sort
    .SetRange Range("A35:W" & Cells(Rows.Count, "J").End(xlUp).Row)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'Removes the extra rows at the end of the cut sheet, as they are not needed (but leave two extra rows at the bottom for looks)
Dim Lastrow1 As Long
Lastrow = ActiveSheet.Cells(Rows.Count, "J").End(xlUp).Row
Rng = "J35:J" & Lastrow
Lastrow1 = Lastrow - Excel.WorksheetFunction.CountBlank(ActiveSheet.Range(Rng))
Dim EndOfCut As Range
    With Range("U1:U32000")
        Set EndOfCut = .Find(What:="CUT LIST SUBTOTAL", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not EndOfCut Is Nothing Then
            Cell_Add = Split(EndOfCut.Address, "$")
            ThisRow = Cell_Add(1)
            ThisCol = Cell_Add(2)
            If ((ThisCol - 1) - (Lastrow1 + 1)) > 3 Then
                Rows((Lastrow1 + 3) & ":" & (ThisCol - 1)).EntireRow.Delete
            End If
        Else
            msgboxresponse = MsgBox("CUT LIST SUBTOTAL not found")
        End If
    End With
'Scrolls through the list and inserts a line between different materials
With Range("J35").Select
    Dim counter As long
    counter = 35
    mtlname = "a"
    mtlname2 = "a"
    Dim EndCount As long
    EndCount = Worksheets("Quote_and_Cut").Cells(Rows.Count, "J").End(xlUp).Row
Do While counter < EndCount
    softEnd0:
    mtlname = "a"
    mtlname2 = "a"
    Do While (mtlname = mtlname2)
        If counter >= EndCount Then 
            GoTo hardEnd0
        Else
            mtlname = Cells(counter, 10)
            counter = counter + 1
            mtlname2 = Cells(counter, 10)
        End If
    Loop
    With Sheets("Quote_and_Cut")
        If mtlname2 = "" Then
            counter = counter + 1
            GoTo softEnd0
        Else
            .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
            Selection.Insert shift:=xlDown
            counter = counter + 1
            EndCount = EndCount + 1
        End If
    End With
hardEnd0:
Loop

'Scrolls through the list and inserts a line between different DIM1
With Range("L35").Select
    counter = 35
    dim1name = "0"
    dim1name2 = "0"
    EndCount = Worksheets("Quote_and_Cut").Cells(Rows.Count, "J").End(xlUp).Row
Do While counter < EndCount
    softEnd1:
    dim1name = "0"
    dim1name2 = "0"
    Do While (dim1name = dim1name2)
        If counter >= EndCount Then 
            GoTo hardEnd1
        Else
            dim1name = Cells(counter, 12)
            counter = counter + 1
            dim1name2 = Cells(counter, 12)
        End If
    Loop
    With Sheets("Quote_and_Cut")
        If Cells(counter, 10) = "" Or Cells(counter -1, 10) = "" Then
            counter = counter + 1
            GoTo softEnd1
        Else
            .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
            Selection.Insert shift:=xlDown
            counter = counter + 1
            EndCount = EndCount + 1
        End If
    End With
Loop
hardEnd1:  
End With
'Scrolls through the list and inserts a line between different DIM2
With Range("M35").Select
    counter = 35
    dim2name = "0"
    dim2name2 = "0"
    EndCount = Worksheets("Quote_and_Cut").Cells(Rows.Count, "J").End(xlUp).Row
Do While counter < EndCount
    softEnd2:
    dim2name = "0"
    dim2name2 = "0"
    Do While (dim2name = dim2name2)
        If counter >= EndCount Then 
            GoTo hardEnd2
        Else
            dim2name = Cells(counter, 13)
            counter = counter + 1
            dim2name2 = Cells(counter, 13)
        End If
    Loop
    With Sheets("Quote_and_Cut")
        If Cells(counter, 10) = "" Or Cells(counter -1, 10) = "" Then
            counter = counter + 1
            GoTo softEnd2
        Else
            .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
            Selection.Insert shift:=xlDown
            counter = counter + 1
            EndCount = EndCount + 1
        End If
    End With
Loop
hardEnd2:  
End With
'Scrolls through the list and inserts a line between different DIM3
With Range("N35").Select
    counter = 35
    dim3name = "0"
    dim3name2 = "0"
    EndCount = Worksheets("Quote_and_Cut").Cells(Rows.Count, "J").End(xlUp).Row
Do While counter < EndCount
    softEnd3:
    dim3name = "0"
    dim3name2 = "0"
    Do While (dim3name = dim3name2)
        If counter >= EndCount Then 
            GoTo hardEnd3
        Else
            dim3name = Cells(counter, 14)
            counter = counter + 1
            dim3name2 = Cells(counter, 14)
        End If
    Loop
    With Sheets("Quote_and_Cut")
        If Cells(counter, 10) = "" Or Cells(counter -1, 10) = "" Then
            counter = counter + 1
            GoTo softEnd3
        Else
            .Range(.Cells(counter, 1), .Cells(counter, 23)).Select
            Selection.Insert shift:=xlDown
            counter = counter + 1
            EndCount = EndCount + 1
        End If
    End With
Loop
hardEnd3:  
End With
'Fixes the Cut List Subtotal SUM, because Excel tries to change it during sort
Dim ThisPos As Range
    With Range("U1:U32000")
        Set ThisPos = .Find(What:="CUT LIST SUBTOTAL", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
        If Not ThisPos Is Nothing Then
            Cell_Add = Split(ThisPos.Address, "$")
            ThisRow = Cell_Add(1)
            ThisCol = Cell_Add(2)
            ActiveWorkbook.Worksheets("Quote_and_Cut").Range("W" & ThisCol).Value = "=SUM(W35:W" & (ThisCol - 1) & ")"
        Else
            msgboxresponse = MsgBox("CUT LIST SUBTOTAL not found")
        End If
    End With
Application.ScreenUpdating = True
End With
End Sub
 
Upvote 0
Solution
My sample data set is quite limited and doesn't contain any formulas or rows with different sizes but your latest version seem to work fine on it. So you are probably good to go now.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
VBA - button to sort by date in ascending and descending order
Replies
6
Views
340
Peter_SSs
Peter_SSs
Dazzawm
  • Solved
Slight Amendment To Code
Replies
6
Views
284
Dazzawm
Dazzawm
SandsB
  • Question
Sorting when a column or 2 is empty
Replies
1
Views
149
DanteAmor
DanteAmor
H
  • Solved
Column sort
Replies
9
Views
83
Fluff
Fluff
O
  • Solved
VBA: Deleting Visible rows using Auto Filter; Excluding Header
Replies
4
Views
343
mumps
mumps

Forum statistics

Threads
1,214,429
Messages
6,119,433
Members
448,897
Latest member
ksjohnson1970

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top