Macro to align data in Multiple columns to a master column

Jastrick

New Member
Joined
Sep 27, 2010
Messages
3
Hi There,

I'm having an issue with a macro. I need to individually compare 4 columns of data (A,B,C,D) each to a 'master column' (In this case, H). The master column is a sorted column containing each possible entry in the first four columns. What I need to do is line up the data in these columns, and if the data is not found, a blank space is left.

an example:
sample data:
ie.
###A###B####C####D .... H
1 Apple Banana Apple Carrot Apple
2 Carrot Grape Carrot Grape Banana
3 #########Grape#####Carrot
4 ##################Grape
etc.....

Desired Result:

ie.
###A####B####C####D .... H
1 Apple######Apple##### Apple
2 ####Banana######### Banana
3 Carrot#####Carrot#Carrot#Carrot
4 ####Grape#Grape##Grape#Grape
etc.....

The Macro MUST NOT, however, edit the master list, just compare to it. Every macro like this I have been able to find edits both columns, not just the one.

I need to get this done ASAP, so any response would be greatly appreciated.

Thanks!
 
Last edited:
Put this in a code module:

Code:
Option Explicit
 
' shg 2009-0330, 0930, 1218
' 2010-0511: modified IsNotLeast to improve speed
 
' Aligns data in rows
 
' Prior to running, create a named range "Keys" that includes the cells in the
' header row above the data to be aligned. The range will, in general, be disjoint.
' The data begins in the row below Keys
 
#Const bDebug = False
 
Sub AlignKeys()
    AlignKeys1 wks:=ActiveSheet
End Sub
 
Function AlignKeys1(wks As Worksheet)
    Dim rKey        As Range    ' cells in header row containing the first column of each dataset
    Dim cell        As Range    ' For Each loop control variable
    Dim iRow        As Long     ' row index
    Dim iCol        As Long     ' column index
    Dim aiCol()     As Long     ' array containing the column indices of Keys
    Dim ar()        As Range    ' an array of ranges containing each of the datasets to be aligned
    Dim iRng        As Long     ' index to range array
    Dim nRng        As Long     ' number of ranges
    Dim ab()        As Boolean  ' "is not least" Boolean array
    Dim rRow        As Range    ' one row of rKey
    Dim rInt        As Range    ' cells in a given dataset range to be pushed down
    Dim rIns        As Range    ' union of the rInt's; range to be pushed down
    '===========================================================================
    #If Not bDebug Then
        Application.ScreenUpdating = False
    #End If
    Application.Calculation = xlCalculationManual
    With wks
        ' Validate Keys range
        On Error Resume Next
        Set rKey = .Range("Keys")
        If Err.Number Then
            MsgBox Prompt:="Named range ""Keys"" does not exist!", _
                   Title:="Oops", Buttons:=vbCritical
            Exit Function   '-------------------------------------------------->
        End If
        On Error GoTo 0
        If rKey.Parent.Index <> wks.Index Then
            MsgBox Prompt:="Named range ""Keys"" is not on sheet """ & _
                           wks.Name & """!", _
                   Title:="Oops", Buttons:=vbCritical
            Exit Function   '-------------------------------------------------->
        End If
        If rKey.Count < 2 Then
            MsgBox Prompt:="Named range ""Keys"" must include at least " & _
                           "two cells in different columns.", _
                   Title:="Oops", Buttons:=vbCritical
            Exit Function   '-------------------------------------------------->
        End If
        If Intersect(rKey, .Rows(rKey.Row)).Count <> rKey.Count Then
            MsgBox Prompt:="All cells of named range ""Keys"" must be in the same row.", _
                   Title:="Oops", Buttons:=vbCritical
            Exit Function   '-------------------------------------------------->
        End If
        '=======================================================================
        ' Initialize variables
        ' ... Size the column and range arrays
        nRng = rKey.Count
        ReDim aiCol(1 To nRng + 1)
        ReDim ar(1 To nRng)
        ' ... Create an ascending array of the columns in Keys
        For Each cell In rKey
            iCol = iCol + 1
            aiCol(iCol) = cell.Column
        Next cell
        aiCol(iCol + 1) = .UsedRange.Column + .UsedRange.Columns.Count
        BubbleSort aiCol                        ' forgive me ...
        ' ... Re-create rKey in ascending order by column
        ' (Which is necessary because each range extends to the
        ' beginning of the range to the right; the rightmost range extends
        ' to the end of the used range)
        Set rKey = .Cells(rKey.Row, aiCol(1))
        For iRng = 2 To nRng
            Set rKey = Union(rKey, .Cells(rKey.Row, aiCol(iRng)))
        Next iRng
        iRow = rKey.Row + 1    ' start of the data to be aligned
        ' ... Create the array of ranges
        For iRng = 1 To nRng
            Set ar(iRng) = .Range(.Cells(iRow, aiCol(iRng)), _
                                  .Cells(.Rows.Count, aiCol(iRng)).End(xlUp))
            Set ar(iRng) = ar(iRng).Resize(, aiCol(iRng + 1) - aiCol(iRng))
        Next iRng
        ' ... Sort each range by the key column
        For iRng = 1 To nRng
            If ar(iRng).Rows.Count > 1 Then
                ar(iRng).Sort Key1:=ar(iRng)(1), _
                              Order1:=xlAscending, _
                              DataOption1:=xlSortNormal, _
                              MatchCase:=False, _
                              Header:=xlNo, _
                              Orientation:=xlTopToBottom
            End If
        Next iRng
        '=======================================================================
        ' Align the keys by inserting cells in each range if the key value
        ' is not the smallest among the other keys.
        Set rRow = Intersect(rKey.EntireColumn, .Rows(iRow))
        Do
            Set rIns = Nothing
            ab = IsNotLeast(rRow)
            If WorksheetFunction.Or(ab) Then
                For iRng = 1 To nRng
                    If ab(iRng) Then
                        Set rInt = Intersect(ar(iRng), .Rows(iRow))
                        If rIns Is Nothing Then Set rIns = rInt
                        Set rIns = Union(rIns, rInt)
                    End If
                Next iRng
            End If
            If Not rIns Is Nothing Then
                #If bDebug Then
                    rIns.Select
                #End If
                rIns.Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
            End If
            iRow = iRow + 1
            Set rRow = Intersect(rKey.EntireColumn, .Rows(iRow))
        Loop While WorksheetFunction.CountA(rRow)   ' quit when all keys are blank
        ' delete the unused rows, which may have some pushed-down formatting
        Range(.Rows(iRow), .Rows(.Rows.Count)).Delete
        wks.UsedRange.Select
    End With
    AlignKeys1 = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Function
Function IsNotLeast(r As Range) As Boolean()
    ' Returns a boolean array the same size as Range r
    ' containing True if the corresponding value of r is
    ' greater than one or more non-empty values in r
    ' Cell values are compared numerically if both are numbers, else lexically
    Dim ab()        As Boolean  ' working Boolean array
    Dim i           As Long     ' index to ab
    Dim cell1       As Range    ' one cell in comparison
    Dim cell2       As Range    ' the other cell
    ReDim ab(1 To r.Count)
    For Each cell1 In r
        i = i + 1
        Select Case VarType(cell1.Value2)
            Case vbString
                For Each cell2 In r
                    If VarType(cell2.Value2) <> vbEmpty Then
                        If StrComp(cell1.Text, cell2.Text, vbTextCompare) = 1 Then ab(i) = True: GoTo NextCell1
                    End If
                Next cell2
            Case vbDouble
                For Each cell2 In r
                    Select Case VarType(cell2.Value2)
                        Case vbString
                            If StrComp(cell1.Text, cell2.Text, vbTextCompare) = 1 Then ab(i) = True: GoTo NextCell1
                        Case vbDouble
                            If cell1.Value2 > cell2.Value2 Then ab(i) = True: GoTo NextCell1
                    End Select
                Next cell2
            Case vbEmpty
                ' fine, do nothing
            Case vbBoolean
                Application.Goto cell1
                ActiveWindow.ScrollRow = cell1.Row
                Application.ScreenUpdating = True
                MsgBox Prompt:="Invalid key value; numbers or strings only", _
                       Title:="Oops", Buttons:=vbCritical
                End
        End Select
NextCell1:
    Next cell1
    IsNotLeast = ab
End Function
Function BubbleSort(av As Variant)
    Dim vTmp        As Variant
    Dim i           As Integer
    Dim bSwap       As Boolean
    Do
        bSwap = False
        For i = LBound(av) To UBound(av) - 1
            If av(i) > av(i + 1) Then
                bSwap = True
                vTmp = av(i)
                av(i) = av(i + 1)
                av(i + 1) = vTmp
            End If
        Next i
    Loop While bSwap
End Function

Assuming row 1 contains headers, select A1:D1 & H1, and in the Names box, left of the formula bar, enter Keys

Then run AlignKeys.

This is a real nice piece of code. Excellent programming!
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top