This just copies the last 3 of shop number
Sub combineShopsLast3()
Dim x, lr As Long

lr = Cells(Rows.Count, 1).End(xlUp).Row

For x = lr To 2 Step -1
    If Left(Cells(x, 2), 6) = Left(Cells(x - 1, 2), 6) Then
        Select Case Cells(x, "J").Value
            Case "0000"
                Cells(x - 1, "F").Value = Right(Cells(x, 2), 3)
            Case "0004"
                Cells(x - 1, "G").Value = Right(Cells(x, 2), 3)
            Case "5001"
                Cells(x - 1, "H").Value = Right(Cells(x, 2), 3)
        End Select
    Cells(x, 2).EntireRow.Delete
    End If
Next x

End Sub