Loop though rows and move data

See if this works for you:

Sub SortData()

Const lFIRST_DATA_ROW = 2
Const lFIRST_DATA_COL = 1
Const lCOLUMN_COUNT = 3

Dim lRowLoop As Long
Dim vCurrentValue As Variant
Dim lOutCol As Long
Dim rngSourceRange As Range
Dim rngDestinationRange As Range

Application.EnableEvents = False

With ActiveSheet

  vCurrentValue = .Cells(lFIRST_DATA_ROW, lFIRST_DATA_COL).Value
  lRowLoop = lFIRST_DATA_ROW + 1
  lOutCol = lFIRST_DATA_COL + lCOLUMN_COUNT
  
  While .Cells(lRowLoop, lFIRST_DATA_COL).Value <> ""
  
    If .Cells(lRowLoop, lFIRST_DATA_COL).Value = vCurrentValue Then
      
      Set rngDestinationRange = .Range(.Cells(lRowLoop - 1, lFIRST_DATA_COL + lCOLUMN_COUNT), .Cells(lRowLoop - 1, lFIRST_DATA_COL + (2 * lCOLUMN_COUNT) - 1))
      Set rngSourceRange = .Range(.Cells(lRowLoop, lFIRST_DATA_COL), .Cells(lRowLoop, lFIRST_DATA_COL + lCOLUMN_COUNT - 1))
      
      rngDestinationRange.Value = rngSourceRange.Value
      rngSourceRange.Cells.Clear
      
    Else
      
      vCurrentValue = .Cells(lRowLoop, lFIRST_DATA_COL).Value
      
    End If
    
    lRowLoop = lRowLoop + 1
    
  Wend
  
End With

Application.EnableEvents = True
  
End Sub