Loop though rows and move data

Hi everyone, hope someone can help.

I would like to be able to compare the number in column A and if they are the same, move the row underneath the first in the set over to the right.

I have attached an excel sheet showing dummy data of how I would like it to look.

Thanks in advance.

Also if someone could point to towards some good learning material for advanced VBA I would appreciate that too.

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