Compare 2 columns and shift down to match up--almost complete!!

[cheerockracy]

I've taken this code from another forum a couple years back and am trying to adapt it to a different set of data. It checks 2 columns and matches up the lines, adding blank cells if the equivalent cells do not match up.

I have 3 inserted columns (D-F). Column D data needs to match up to the equal value in column B. Right now the macro shifts everything accurately except when the data does not exist in column D it will only shift columns A-C. I need it to ALSO shift from G-AX to include both sides of the original data.

'routine to shuffle and match 2 columns (must be sorted in ascending order).
     'it basically keeps shuffling until it  finds matching  cells and leaves
     'blanks where the cells do not match.
 
    Dim Last_Row As Long
    Dim Row_Number As Integer
 
    Const FIRST_COLUMN = 2 'the column number for the first column of data
    Const SECOND_COLUMN = 4 'the column number for the second column of data (they dont have to be side by side)
    Const COLUMN_WIDTH = 1 'the number of columns wide that need to be shuffled down
    Const COLOUR_CODE = True
 
    Row_Number = 8 'the row number where to start.
 
     'check if empty  sheet.
    Last_Row = Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
    If Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row <= 1 Then
         MsgBox ("No rows to work with")
        Exit Sub
    End If
 
 
    Do
        Last_Row = Cells.Find("*", [a1], , , xlByRows, xlPrevious).Row
 
        If Not (IsEmpty(Cells(Row_Number, FIRST_COLUMN)) Or IsEmpty(Cells(Row_Number, SECOND_COLUMN))) Then
            If (Cells(Row_Number, FIRST_COLUMN) <> Cells(Row_Number, SECOND_COLUMN)) Then
                If Cells(Row_Number, FIRST_COLUMN) < Cells(Row_Number, SECOND_COLUMN) Then
                    Range(Cells(Row_Number, SECOND_COLUMN), Cells(Row_Number, SECOND_COLUMN + COLUMN_WIDTH + 50)).Insert Shift:=xlDown
                    If COLOUR_CODE Then
                        Range(Cells(Row_Number, SECOND_COLUMN), Cells(Row_Number, SECOND_COLUMN + COLUMN_WIDTH + 1)).Interior.ColorIndex = 3
                    End If
                Else
                    Range(Cells(Row_Number, 1), Cells(Row_Number, FIRST_COLUMN + COLUMN_WIDTH)).Insert Shift:=xlDown
                    If COLOUR_CODE Then
                        Range(Cells(Row_Number, 1), Cells(Row_Number, FIRST_COLUMN + COLUMN_WIDTH)).Interior.ColorIndex = 3
                    End If
                End If
            Else
                If COLOUR_CODE Then
                    Range(Cells(Row_Number, SECOND_COLUMN), Cells(Row_Number, SECOND_COLUMN + COLUMN_WIDTH)).Interior.ColorIndex = 43
                    Range(Cells(Row_Number, 1), Cells(Row_Number, FIRST_COLUMN + COLUMN_WIDTH)).Interior.ColorIndex = 43
                End If
            End If
        End If
 
        Row_Number = Row_Number + 1
     Loop Until (Row_Number > Last_Row)

Thanks in advance for your help and time!
<STYLE>.alt2 font {font: 11px monospace !important;color: #333 !important;}</STYLE>

 

[pboltonchina]

Try this on a copy of your data

Sub Line_Em_Up()
'Author:    Jerry Beaucaire
'Date:      7/5/2010
'Summary:   Line up a random number of columns so all matching
'           items are on the same rows
Dim LC  As Long
Dim Col As Long
Dim LR  As Long
Application.ScreenUpdating = False

'Spot last column of data
    LC = Cells(1, Columns.Count).End(xlToLeft).Column
   
'Add new key column  to collect unique values
    Cells(1, LC + 1) = "Key"
    For Col = 1 To LC
        Range(Cells(2, Col), Cells(Rows.Count, Col)).SpecialCells(xlConstants).Copy _
           Cells(Rows.Count, LC + 1).End(xlUp).Offset(1)
    Next Col

    Columns(LC + 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Cells(1, LC + 2), Unique:=True
    Columns(LC + 2).Sort Key1:=Cells(2, LC + 2), Order1:=xlAscending, Header:=xlYes

'Fill in new table headers
    With Range(Cells(1, LC + 3), Cells(1, LC + 2 + LC))
        .Formula = "=INDEX(1:1, COLUMN(A1))"
        .Value = .Value
    End With

'Fill in new table values
    LR = Cells(Rows.Count, LC + 2).End(xlUp).Row
    With Range(Cells(2, LC + 3), Cells(LR, LC + 2 + LC))
        .FormulaR1C1 = "=IF(ISNUMBER(MATCH(RC" & LC + 2 & ",C[-" & LC + 2 _
                        & "],0)), RC" & LC + 2 & ", """")"
        .Value = .Value
    End With

'Cleanup/Erase old values
    Range("A1", Cells(1, LC + 2)).EntireColumn.Delete xlShiftToLeft
    Application.ScreenUpdating = True
End Sub

 

[Gary McMaster]

There's something similar here:

http://www.mrexcel.com/forum/showthread.php?t=543645

Maybe it will help.

Gary