Search code examples
excelvba

Identify a section and reorder rows in the section

The code below moves rows but it is not reordering as desired.

Objective: Reorder Excel sheet section, as defined by starting with grey and ending with blue rows, making the last row in the section the first and so on then going to the next section and doing the same. (Only if rows have something in them.)

What's happening:
1-Finds section somewhat correctly but the reorder seems to overwrite and include blank rows OR do nothing. (When I take out the first section which is empty).
2-Not finding the next section after selecting no (maybe I don't specifically say that but I thought with the next firstRow it would)

The basic sheet looks like this:
enter image description here

Sub ReorderSection()

    ' Define variables
    Dim ws As Worksheet
    Dim firstRow As Long, lastRow As Long
    Dim cellValue As String
    Dim tempRange As Range, cell As Range
    Dim i As Long
    
    ' Set the worksheet to be processed
    Set ws = srcSht = ThisWorkbook.Worksheets("Sheet1")
    
    ' Find the first row with gray color
    For firstRow = 1 To ws.UsedRange.Rows.Count
        If ws.Cells(firstRow, 1).Interior.Color = 13158600 Then
            Exit For
        End If
    Next firstRow
    
    ' If no gray row found, exit the sub
    If firstRow = ws.UsedRange.Rows.Count Then
        MsgBox "No section found!", vbExclamation
        Exit Sub
    End If
    
    ' Find the last row with blue color
    For lastRow = ws.UsedRange.Rows.Count To 1 Step -1
        If ws.Cells(lastRow, 1).Interior.Color = 15773696 Then
            Exit For
        End If
    Next lastRow
    
    ' If no blue row found, exit the sub
    If lastRow = 1 Then
        MsgBox "No section found!", vbExclamation
        Exit Sub
    End If
    
    ' Are these the start and end rows
    Dim result As Integer
    result = MsgBox("Reorder rows " & firstRow & " to " & lastRow & "?", vbYesNo)
    
    ' If yes, reorder the rows
    If result = vbYes Then
        'temp range of section data
        Set tempRange = ws.Range("A" & firstRow, "Z" & lastRow)
        
        ' Loop through rows in reverse order and place them at the beginning
        For i = lastRow - 1 To firstRow Step 1
            Set cell = tempRange.Rows(i)
            cell.Cut Destination:=ws.Rows(firstRow)
            firstRow = firstRow + 1
        Next i
        
        ' message reordered
        MsgBox "Section reordered successfully!", vbInformation
    End If
    
End Sub

Markdown Table:

| GRAY            | Pd1    |
|-----------------|--------|
| BLACK           |        |
| BLUE            | CHT    |
| GRAY            | C      |
| LBLUE           | Pre-CM |
| LBLUE           | Pre-M  |
| ORANGE          | Tx     |
| WHITE ORDER     | ZH     |
| LBLUE           | Post T |
| LBLUE           | Pres   |
| LBLUE           | GF     |
| BLUE            | L      |
| GRAY            | C      |
| WHITE ORDER6    |      6 |
| WHITE ORDER5    |      5 |
| WHITE ORDER4    |      4 |
| WHITE ORDER3    |      3 |
| WHITE ORDER2    |      2 |
| WHITE ORDER1    |      1 |
| BLUE            | L      |
| GRAY            | C      |
| WHITE ORDER1    | 1L1    |
| whITE ORDER2    | 1L2    |
| BLUE            | L      |
| GRAY            | C      |
| WHITE REMINDER3 | 3R     |
| WHITE REMINDER2 | 2R     |
| WHITE REMINDER1 | 1R     |
Solution

  • As far as I can see you have at least a few problems with the code:

    1. Your lastRow search does not find the first Blue row after the first Gray row, but it finds the last Blue row in the whole UsedRange of the excel sheet. You need to add an outer loop to your code that works through all sections. See my (edited) working code example below that addresses that.

    2. Your index checking for color not found is buggy Instead of:

       If firstRow = ws.UsedRange.Rows.Count

    You should have:

        If firstRow > ws.UsedRange.Rows.Count

    as firstRow will be incremented by an extra +1 as the loop is exited. Similarly

    If lastRow = 1 Then

    Should be:

    If lastRow < 1 Then

    1. Another important issue is with using the range "Cut" VBA function with the "Destination" argument. It does not have the meaning of "cut and insert", but it does "cut and paste", so instead of inserting the rows as you try to reorder by cutting them from the bottom, you end up overwriting the rows at the top. The contents of your loop can be modified as follows (using a sequence of range.Cut and range.Insert instead):

           For i = firstRow + 1 To lastRow - 2
        Set cell = ws.Rows(lastRow - 1)
        cell.Cut
        ws.Rows(i).Insert xlDown
     Next i

    2. The complete code is here (I removed a dangling reference to variable srcSht which is probably defined as a global one in your workbook). Turning off Application.ScreenUpdating for the duration of the Cut-and-Insert loop for improved performance. I kept your original code showing message boxes in place, but it can be removed if you want to process the whole sheet uninterrupted:

    Sub ReorderSection()

     ' Define variables
     Dim ws As Worksheet
     Dim firstRow As Long, lastRow As Long
     Dim cellValue As String
     Dim tempRange As Range, cell As Range
     Dim i As Long

    ' Set the worksheet to be processed
     Set ws = ThisWorkbook.Worksheets("Sheet1")

    ' Loop through all sections (outer loop)
     currentRow = 1
     Do While True
     
    ' Find the first row with gray color
      firstRow = -1
      Do While currentRow <= ws.UsedRange.Rows.Count
        If ws.Cells(currentRow, 1).Interior.Color = 13158600 Then
          firstRow = currentRow
          currentRow = currentRow + 1
          Exit Do
        End If
        currentRow = currentRow + 1
      Loop

     ' If no gray row found, exit outer loop
      If firstRow = -1 Then
        MsgBox "No more sections found (first row)! Exiting.", vbExclamation
        Exit Do
      End If

    ' Find the last row of the section with blue color
      lastRow = -1
      Do While currentRow <= ws.UsedRange.Rows.Count
        If ws.Cells(currentRow, 1).Interior.Color = 15773696 Then
          lastRow = currentRow
          currentRow = currentRow + 1
          Exit Do
        End If
        currentRow = currentRow + 1
      Loop

    ' If no blue row found, exit outer loop
      If lastRow = -1 Then
        MsgBox "No more sections found (last row)! Exiting.", vbExclamation
        Exit Do
      End If

    ' Are these the start and end rows
      If lastRow - firstRow <= 2 Then
         MsgBox "No need to reorder rows " & firstRow & " to " & lastRow & ". Skipping", vbInformation
      Else
          Dim result As Integer
          result = MsgBox("Reorder rows " & firstRow & " to " & lastRow & "?", vbYesNo)
    
        ' If yes, reorder the rows
          If result = vbYes Then
            ' Loop through rows in reverse order and place them at the beginning
            Application.ScreenUpdating = False
            For i = firstRow + 1 To lastRow - 2
                ws.Rows(lastRow - 1).Cut
                ws.Rows(i).Insert xlDown
            Next i
            Application.ScreenUpdating = True
            ' message reordered
            MsgBox "Section reordered successfully!", vbInformation
          End If
       End If
    Loop
End Sub