Perform Loop Based on Groupings of Rows

Question

this is my first time posting!

I have a data set similar to

Essentially there is data split into three columns (ID, Record, and Variable). For each "group" (based on the ID they share), I need to be able to reset the order of the records so that 4 and 5 come last in the "group." Then, the function would be able to go to the next one. Finally, I would expect a result like

A few key points:

1. I cannot use sorting/filtering because none of the IDs/Records/Variables in the true data set are in numeric order
2. Cannot split it out into different sheets/macros, because there are thousands of unique IDs.

Tried to work through this, but have some issues with my code doing nothing (below). Any ideas?

Sub GrpUpdate()

Dim f As Long
Dim i As Long
Dim last As Long

grpOne = "4"
grpTwo = "5"
i = 2
f = i
last = Range("A:A").Find(what:=Range("A" & f).Value, after:=Range("A" & f), searchdirection:=xlPrevious, LookIn:=xlValues).Row

For f = i To last

    If f = last Then
        i = last + 1
        f = i
        last = Range("A:A").Find(what:=Range("A" & f).Value, after:=Range("A" & f), searchdirection:=xlPrevious, LookIn:=xlValues).Row
        
    ElseIf Not IsError(Application.Match(grpOne, "B" & f & ":" & "B" & last, 0)) And Not IsError(Application.Match(grpTwo, "B" & f & ":" & "B" & last, 0)) Then
        Rows(Range("B" & f & ":" & "B" & last).Find(what:=grpOne, after:=Range("B" & f), searchdirection:=xlPrevious, LookIn:=xlValues).Row).Cut
        Rows(last).Insert
        Rows(Range("B" & f & ":" & "B" & last).Find(what:=grpTwo, after:=Range("B" & f), searchdirection:=xlPrevious, LookIn:=xlValues).Row).Cut
        Rows(last).Insert
        
    ElseIf Not IsError(Application.Match(grpOne, "B" & f & ":" & "B" & last, 0)) Then
        Rows(Range("B" & f & ":" & "B" & last).Find(what:=grpOne, after:=Range("B" & f), searchdirection:=xlPrevious, LookIn:=xlValues).Row).Cut
        Rows(last).Insert
        
    ElseIf Not IsError(Application.Match(grpTwo, "B" & f & ":" & "B" & last, 0)) Then
        Rows(Range("B" & f & ":" & "B" & last).Find(what:=grpTwo, after:=Range("B" & f), searchdirection:=xlPrevious, LookIn:=xlValues).Row).Cut
        Rows(last).Insert
        
    End If

Next f

End Sub

Answer 1

Try this out:

Sub GrpUpdate()
    Dim f As Range, first As Long, last As Long
    Dim ws As Worksheet, numRows As Long, addrGroups As String, arrLast, g
    
    Set ws = ActiveSheet      'or whatever
    first = 2                 'start here
    
    arrLast = Array("4", "5") 'items which (if present) should be last for each Id, in order
    
    Do While Len(ws.Cells(first, "A").Value) > 0
        
        With ws.Cells(first, "A") 'find the last value
            last = ws.Range("A:A").Find(what:=.Value, after:=.Cells(1), _
                                searchdirection:=xlPrevious, lookat:=xlWhole).Row
        End With
        numRows = 1 + (last - first)
        
        If numRows > 1 Then 'ignore single rows
            'Using the range address because we're cutting rows which can be
            '   weird with Range references....
            addrGroups = ws.Cells(first, "B").Resize(numRows).Address 'address for the "group" range
            For Each g In arrLast   'loop items to be ordered last
                Set f = ws.Range(addrGroups).Find(what:=g, lookat:=xlWhole)
                If Not f Is Nothing Then
                    f.EntireRow.Cut 'move the found row to the end of the group
                    ws.Rows(last + 1).Insert
                End If
            Next g
        End If           '>1 row    
        first = last + 1 'next Id
    Loop
End Sub