How to sort multiple columns sequentially and have the rows merge for the same values?

Question

I have a really crude code for sorting the columns out and merging them together as seen by my code. The first 3 blocks are to sort them first by column A, then column B, and then column C.

I want it so that users can see the breakdown in columns A, B and C. Column A being the material, B being the material variant, and C the fabrication method and not have to look at each entry row by row.

Is there a more efficient way of sorting the columns without having to go through the 3 blocks of code? And merging them at the end for me seems to not work as well and the rows end up getting mixed and not properly sorted.

Dim wsproc As Worksheet: Set wsproc = ThisWorkbook.Worksheets("Procurement Table")

For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
    For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
        If _
        wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
        Then
        wsproc.Rows(i3 - 1).Cut
        wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
        End If
    Next
Next

For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
    For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
        If _
        wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
        And wsproc.Cells(k3, 2).Value = wsproc.Cells(i3 - 1, 2).Value _
        Then
        wsproc.Rows(i3 - 1).Cut
        wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
        End If
    Next
Next

For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
    For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
        If _
        wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
        And wsproc.Cells(k3, 2).Value = wsproc.Cells(i3 - 1, 2).Value _
        And wsproc.Cells(k3, 3).Value = wsproc.Cells(i3 - 1, 3).Value _
        Then
        wsproc.Rows(i3 - 1).Cut
        wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
        End If
    Next
Next

'To merge duplicate rows column-wise
Dim p As Variant
Dim iArray As Variant
Dim l%

iArray = Array(1, 2, 3)
ActiveSheet.ListObjects(1).Unlist

For Each p In iArray
    For l = wsproc.UsedRange.Rows.Count To 2 Step -1
        If wsproc.Cells(l, p).Value = wsproc.Cells(l - 1, p).Value _
        Then
        wsproc.Range(wsproc.Cells(l, p), wsproc.Cells(l - 1, p)).Merge
        End If

    Next
Next p

Answer 1

Range.Sort

Sub Main

  Dim sheet as Worksheet: Set sheet = ThisWorkbook.Sheets("Sheet Name")

  Dim lastRow as Long
  Dim lastColumn as Integer
  Dim sheetRange as Range

  Dim sheetArray as Variant
  Dim mergeRangesArray as Variant

  Dim startRows as Variant
  Dim i as Long

  lastRow = sheet.UsedRange.Rows.Count
  lastColumn = sheet.UsedRange.Columns.Count

  'Assign the sheet's used range to a variable
  Set sheetRange = sheet.Range(sheet.Cells(1, 1), sheet.Cells(lastRow, lastColumn))

  'Use the Range.Sort method to sort
  sheetRange.Sort key1:=sheet.Range("A1:A" & lastRow), order1:=xlAscending, _
  key2:=sheet.Range("B1:B" & lastRow), order2:=xlAscending, _
  key3:=sheet.Range("C1:C" & lastRow), order3:=xlAscending, Header:=xlYes

  'Assign the sheet's range values to a 2D array
  sheetArray = sheetRange

  'Loop through the rows of the 2D array, and add ranges that need to be merged
  'to the mergeRangesArray. The mergeRangesArray is an array of strings which
  'are looped through at the end of the Sub to merge cells.
  'The string argument for Range() has a character limit of 255.
  startRows = Array(2, 2, 2)
  For i = 3 to lastRow
      If sheetArray(i, 1) <> sheetArray(i - 1, 1) Then
          If i - startRows(0) > 1 Then
              Call AddToRangeArray(mergeRangesArray, "A" & startRows(0) & ":A" & i - 1)
              If i - startRows(1) > 1 Then
                  Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
              End If
              If i - startRows(2) > 1 Then
                  Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
              End If
          End If
          startRows = Array(i, i, i)
      Else
        
          If sheetArray(i, 2) <> sheetArray(i - 1, 2) Then
              If i - startRows(1) > 1 Then
                  Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
              End If
              startRows(1) = i
          End If
          If sheetArray(i, 3) <> sheetArray(i - 1, 3) Then
              If i - startRows(2) > 1 Then
                  Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
              End If
              startRows(2) = i
          End If
      End If
  Next i
  If i - startRows(0) > 1 Then
      Call AddToRangeArray(mergeRangesArray, "A" & startRows(0) & ":A" & i - 1)
  End If
  If i - startRows(1) > 1 Then
      Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
  End If
  If i - startRows(2) > 1 Then
      Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
  End If
  Application.DisplayAlerts = False
  For i = 1 to UBound(mergeRangesArray)
      sheet.Range(mergeRangesArray(i)).Merge
  Next i
  Application.DisplayAlerts = True

End Sub

Sub AddToRangeArray(mergeRangesArray as variant, myString as string)

    Dim i as Integer
    Dim j as Integer
    
    If IsEmpty(mergeRangesArray) = False Then
        i = UBound(mergeRangesArray)
        j = Len(mergeRangesArray(i))
        
        If j + Len("," & myString) <= 255 Then
            mergeRangesArray(i) = mergeRangesArray(i) & "," & myString
        Else
            ReDim Preserve mergeRangesArray(1 to i + 1)
            mergeRangesArray(i + 1) = myString
        End If
    Else
        ReDim mergeRangesArray(1 to 1)
        mergeRangesArray(1) = myString
    End If

End Sub