Moving cells around help needed.

[Learner99]

Hi,
I'm trying to make a macro that will make my life easier. What I would like to do is scan through column "A", when the next cell down does not match the previous cell. I would like to move that Cell and the cells next to it to the top of a new un-used column.

I created an example of what I'm looking to do

Raw Data:
Column A|Column B|Column C
XMG1|***|9611
XMG1|TZX|19621
XMG2|***|9261
XMG2|TZX|9621
XMG2|WQR|39561
XM12|***|9261
XM12|TZX|19621
XM12|WQR|39561
AMG2|***|9261
AMG2|TZX|19621

etc....

Output:
Column A|Column B|Column C|Column D|Column E|Column F|Column G|Column H|Column I|Column J|Column H|Column L| etc....
XMG1|***|9611|XMG2|***|9261|XM12|***|9261|AMG2|***|9261
XMG1|TZX|19621|XMG2|TZX|19621|XM12|TZX|19621|AMG2|TZX|19621
|||XMG2|WQR|39561|XM12|WQR|39561

Here is the code I've come up with so far. The results are close but not what I want to happen.

Sub SelectAll()
 
Dim RowInfo() As Variant
Dim counter As Long
Dim r As Range
Dim n As Long
Dim x As Integer
 
    Range("A1").Select
    Selection.End(xlDown).Select
 
    Set r = Range("A1:" & Selection.Address)              'This is where you set the column to sort on
   
    For n = 1 To r.Rows.Count                             ' For loop start
 
    If Not IsEmpty(r.Cells(n + 1, 1)) Then                ' This If statement is supposed to stop blank lines
        If r.Cells(n, 1) <> r.Cells(n + 1, 1) Then        ' (N is the row and ,1 is the column)
                                                          ' This will check the cells against each other
          Range("A1:" & r.Cells(n, 1).Address).Select     ' Select rows to be cut
          Selection.Cut
   
             Range("B1").Select                           ' look for an empty column to paste into
             Do Until IsEmpty(ActiveCell)
               ActiveSheet.Paste
               ActiveCell.Offset(0, 1).Select
             Loop
   
          x = Range("A1:" & r.Cells(n, 1).Address).Count  ' Get number of rows that will be deleted
          Range("A1:" & r.Cells(n, 1).Address).Select     ' Get the range to delete rows
          Selection.Delete Shift:=xlUp                    ' delete rows
          Range("A1").Select
          n = x                                           'Subtract off the number of rows from the count in the 4 loop
        End If
    End If
   
    Next n
 
End Sub

Thank you very much for your time and help.

 

[onlyadrafter]

Hello,

although this works, it is not the most elegant

Sub MOVE_TO_COLUMN()
    Application.ScreenUpdating = False
    MY_CELLS = 1
    For MY_ROWS = 1 To Cells(Rows.Count, MY_CELLS).End(xlUp).Row
        MY_LAST_ROW = Cells(Rows.Count, MY_CELLS).End(xlUp).Row
        If Not IsEmpty(Cells(MY_ROWS + 1, MY_CELLS).Value) Then
            If Cells(MY_ROWS, MY_CELLS).Value <> Cells(MY_ROWS + 1, MY_CELLS).Value Then
                Range(Cells(MY_ROWS + 1, MY_CELLS), Cells(MY_LAST_ROW, MY_CELLS + 2)).Copy
                Range("A1").End(xlToRight).Offset(0, 1).PasteSpecial (xlPasteValues)
                Range(Cells(MY_ROWS + 1, MY_CELLS), Cells(MY_LAST_ROW, MY_CELLS + 2)).Delete (xlUp)
                MY_CELLS = MY_CELLS + 3
                MY_ROWS = 0
                GoTo CONT
            End If
        End If
CONT:
    Next MY_ROWS
    Application.ScreenUpdating = True
End Sub

it will error out should you run out of columns.