Text Functions‎ > ‎

Line Up Matches

                                             Sample File - LineEmUp.xls

PROBLEM #1:
"I have data for membership by year that needs to be rearranged so that matching members appear in the same row"

                             BEFORE
  A B C
1 2007 2008 2009
2 Byram Andover Andover
3 Montvale Byram Byram
4 Neptune Chatham Chatham
5 Orange Montvale Dover
6 Prospect Neptune Montvale
7 Randolph Newton Neptune
8   Orange Orange
9   Prospect Paramus
10     Prospect


                          AFTER
  A B C
1 2007 2008 2009
2   Andover Andover
3 Byram Byram Byram
4   Chatham Chatham
5     Dover
6 Montvale Montvale Montvale
7 Neptune Neptune Neptune
8   Newton  
9 Orange Orange Orange
10     Paramus
11 Prospect Prospect Prospect
12 Randolph    

SPECIFICATIONS:
  1. Works with any number of columns
  2. Data starts in column A
  3. Row 1 is "headers" for each column of data

CODE

Option Explicit

Sub LineEmUp()
'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 w/formatting
    Range("A1", Cells(1, LC)).Copy Cells(1, LC + 3)

'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
    Columns.Autofit
    Application.ScreenUpdating = True
End Sub



PROBLEM #2:
"I have two sections of data.  I need to line up the "codes" from each group so they are on the same row.  Codes in the second group that are not in the first group aren't needed at all."

                                                                                BEFORE
  A B C D E F G H
1 QTY CODE # Description VK Name VK EAN CODE VK EAN CODE DX Name DX Description DX
2 2 ST 808100 Description #1 Item Name #1 9323705005004 9323705033333 Item Name #A Description #A
3 90 TBL 275821 Description #2 Item Name #2 9323705004083 9323705004083 Item Name #B Description #B
4 30 TBL 275504 Description #3 Item Name #3 9323705004045 9312146077777 Item Name #C Description #C
5 30 TBL 275673 Description #4 Item Name #4 9323705004021 9312146008888 Item Name #D Description #D
6 4 GR 430127 Description #5 Item Name #5 9312146003380 9312146003335 Item Name #E Description #E
7 125 ML 430257 Description #6 Item Name #6 9312146003335 9323705005004 Item Name #F Description #F
8 69 ML 430238 Description #7 Item Name #7 9312146002727 9323705004021 Item Name #G Description #G


                                                                               AFTER
  A B C D E F G H
1 QTY CODE # Description VK Name VK EAN CODE VK EAN CODE DX Name DX Description DX
2 69 ML 430238 Description #7 Item Name #7 9312146002727      
3 125 ML 430257 Description #6 Item Name #6 9312146003335 9312146003335 Item Name #E Description #E
4 4 GR 430127 Description #5 Item Name #5 9312146003380      
5 30 TBL 275673 Description #4 Item Name #4 9323705004021 9323705004021 Item Name #G Description #G
6 30 TBL 275504 Description #3 Item Name #3 9323705004045      
7 90 TBL 275821 Description #2 Item Name #2 9323705004083 9323705004083 Item Name #B Description #B
8 2 ST 808100 Description #1 Item Name #1 9323705005004 9323705005004 Item Name #F Description #F

SPECIFICATIONS:
  1. Row 1 is "headers" for each column of data
  2. Gaps will appear only in the right section where there is no match

CODE

Option Explicit

Sub LineEmUp2()
'Author:    Jerry Beaucaire
'Date:      10/27/2010
'Summary:   Align codes in columns C and D removing all D values not in C
Dim i As Long, LR As Long
Application.ScreenUpdating = False

'Last row with data in column F
    LR = Range("F" & Rows.Count).End(xlUp).Row

'Remove items in F:H that aren't in E
    Columns("F:F").Insert Shift:=xlToRight
    Range("F2:F" & LR).FormulaR1C1 = "=ISNUMBER(MATCH(RC[1],C[-1],0))"
   
    Columns("F:F").AutoFilter
    Columns("F:F").AutoFilter Field:=1, Criteria1:="FALSE"
   
    Range("F2:I" & LR).ClearContents
    Columns("F:F").Delete xlShiftToLeft
   
'Sort both section so numbers are ascending in E and F
    Columns("A:E").Sort Key1:=Range("E2"), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    Columns("F:H").Sort Key1:=Range("F2"), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'line up remaining items so F lines up with E
    i = 2
    Do
        If Cells(i, "E") > Cells(i, "F") And Cells(i, "F") > "" Then
            Cells(i, "A").Resize(1, 5).Insert xlShiftDown
        ElseIf Cells(i, "E") < Cells(i, "F") And Cells(i, "E") > "" Then
            Cells(i, "F").Resize(1, 3).Insert xlShiftDown
        End If
        i = i + 1
    Loop Until Cells(i, "E") = "" And Cells(i, "F") = ""

Application.ScreenUpdating = True
End Sub



PROBLEM #3:
"I have two sections of data.  I need to line up the "codes" from each group so they are on the same row. No data is to be deleted, so there will be blanks in both groups where there is no match."

                                            BEFORE
  A B C D E F G H
1 QTY CODE # Description VK Name VK EAN CODE VK EAN CODE DX Name DX Description DX
2 2 ST 808100 Description #1 Item Name #1 9323705005004 9323705033333 Item Name #A Description #A
3 90 TBL 275821 Description #2 Item Name #2 9323705004083 9323705004083 Item Name #B Description #B
4 30 TBL 275504 Description #3 Item Name #3 9323705004045 9312146077777 Item Name #C Description #C
5 30 TBL 275673 Description #4 Item Name #4 9323705004021 9312146008888 Item Name #D Description #D
6 4 GR 430127 Description #5 Item Name #5 9312146003380 9312146003335 Item Name #E Description #E
7 125 ML 430257 Description #6 Item Name #6 9312146003335 9323705005004 Item Name #F Description #F
8 69 ML 430238 Description #7 Item Name #7 9312146002727 9323705004021 Item Name #G Description #G

                                               AFTER
  A B C D E F G H
1 QTY CODE # Description VK Name VK EAN CODE VK EAN CODE DX Name DX Description DX
2 69 ML 430238 Description #7 Item Name #7 9312146002727      
3 125 ML 430257 Description #6 Item Name #6 9312146003335 9312146003335 Item Name #E Description #E
4 4 GR 430127 Description #5 Item Name #5 9312146003380      
5           9312146008888 Item Name #D Description #D
6           9312146077777 Item Name #C Description #C
7 30 TBL 275673 Description #4 Item Name #4 9323705004021 9323705004021 Item Name #G Description #G
8 30 TBL 275504 Description #3 Item Name #3 9323705004045      
9 90 TBL 275821 Description #2 Item Name #2 9323705004083 9323705004083 Item Name #B Description #B
10 2 ST 808100 Description #1 Item Name #1 9323705005004 9323705005004 Item Name #F Description #F
11           9323705033333 Item Name #A Description #A

SPECIFICATIONS:
  1. Row 1 is "headers" for each column of data
  2. Gaps will appear in both sections where there are no matches

CODE

Option Explicit

Sub LineEmUp3()
'Author:    Jerry Beaucaire
'Date:      10/27/2010
'Summary:   Align codes in columns C and D removing all D values not in C
Dim i As Long, LR As Long
Application.ScreenUpdating = False

'Last row with data in column F
    LR = Range("F" & Rows.Count).End(xlUp).Row

'Sort both section so numbers are ascending in E and F
    Columns("A:E").Sort Key1:=Range("E2"), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    Columns("F:H").Sort Key1:=Range("F2"), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'line up remaining items so F lines up with E
    i = 2
    Do
        If Cells(i, "E") > Cells(i, "F") And Cells(i, "F") > "" Then
            Cells(i, "A").Resize(1, 5).Insert xlShiftDown
        ElseIf Cells(i, "E") < Cells(i, "F") And Cells(i, "E") > "" Then
            Cells(i, "F").Resize(1, 3).Insert xlShiftDown
        End If
        i = i + 1
    Loop Until Cells(i, "E") = "" And Cells(i, "F") = ""

Application.ScreenUpdating = True
End Sub



PROBLEM #4:
"I have a random number of data sections, the data is in column groups of 2 or more columns.  I need to line up the "codes" from each group so they are on the same row. No data is to be deleted, so there will be blanks in the groups where there is no match.  The columns groups vary and the number of groups of data vary, and I'd like to be able to "match" by any column IN the group, not always column 1 of the groups. Data in the groups may not be sorted. Data may or may not have headers in row 1."

                                     Example #1           BEFORE (no headers)
  A B C D E F G H
1 abc123 4 abc123 5 abc124 4 abc121 5
2 abc124 5 abc125 3 abc127 5 abc123 3
3 abc127 3 abc126 4 abc129 3 abc129 4
4 abc128 3 abc127 5 abc122 3 abc127 5

                                                AFTER
  A B C D E F G H
2             abc121 5
3         abc122 3    
4 abc123 4 abc123 5     abc123 3
5 abc124 5     abc124 4    
6     abc125 3        
7     abc126 4        
8 abc127 3 abc127 5 abc127 5 abc127 5
9 abc128 3            
10         abc129 3 abc129 4


                                   Example #2           BEFORE (with headers and with three columns)
 ABCDEFGHIJKL
1CodeRateSpeciesCodeRateSpeciesCodeRateSpeciesCodeRateSpecies
2abc1234catabc1235hamsterabc1244snakeabc1215cat
3abc1245dogabc1253dogabc1275birdabc1233lizard
4abc1273birdabc1264lizardabc1293catabc1294hamster
5abc1283lizardabc1275catabc1223dogabc1275bird

                                                                AFTER (matched by Species this time through)
 ABCDEFGHIJKL
1CodeRateSpeciesCodeRateSpeciesCodeRateSpeciesCodeRateSpecies
2abc1273bird   abc1275birdabc1275bird
3abc1234catabc1275catabc1293catabc1215cat
4abc1245dogabc1253dogabc1223dog   
5   abc1235hamster   abc1294hamster
6abc1283lizardabc1264lizard   abc1233lizard
7      abc1244snake   

SPECIFICATIONS:
  1. Macro will prompt you to indicate how many columns make up each group
  2. Macro will prompt you to indicate if row 1 has headers or not
  3. Macro will prompt you to indicate which column within each group has the "values to match by" (example 2 we matched by Species)
  4. Will work with any number of column groups
  5. Gaps will appear in both sections where there are no matches

CODE

Option Explicit

Sub LineEmUp4()
'Author:    Jerry Beaucaire
'Date:      7/12/2011
'Summary:   Line up a random number of paired columns so all matching
'           items are on the same rows, matches are in odd numbered columns
Dim LR     As Long
Dim FR     As Long
Dim LC     As Long
Dim Col    As Long
Dim SrtCol As Long
Dim Cols   As Long
Dim Hdrs   As Long
Dim off    As Boolean
Dim vFND   As Range
Dim vRNG   As Range
Dim v      As Range

'Ask how many columns go together
    Cols = Application.InputBox("How many columns go together in groups?", "Column Groups", 2, Type:=1)
    If Cols = 0 Then Exit Sub
   
'Ask if headers exist
    Hdrs = MsgBox("Does the first row contain column headers? (No means row 1 is data, too.)", vbYesNo, "Headers")
   
'Spot last column of data and check the grouping
    LC = Cells(1, Columns.Count).End(xlToLeft).Column
    If LC Mod Cols <> 0 Then
        MsgBox "The number of data columns does not match grouping, please check your data."
        Exit Sub
    End If
   
'Indicate how to sort the data groups, column must be the same in each group
    Do
        SrtCol = Application.InputBox("Within each group of " & Cols & " columns, which column should the data be matched by?", _
            "Match Column", 1, Type:=1)
        If SrtCol <= Cols And SrtCol > 0 Then Exit Do
        If MsgBox("The column groups do not have that many columns, try again?", _
            vbYesNo, "Retry?") = vbNo Then Exit Sub
    Loop
           
    Application.ScreenUpdating = False

'Sort all groups to get them ascending properly
    For Col = 1 To LC Step Cols
        If Hdrs = 6 Then
            Columns(Col).Resize(, Cols).Sort Key1:=Cells(2, Col - 1 + SrtCol), order1:=xlAscending, Header:=xlYes
        Else
            Columns(Col).Resize(, Cols).Sort Key1:=Cells(1, Col - 1 + SrtCol), order1:=xlAscending, Header:=xlNo
        End If
    Next Col
           
'Add new key column  to collect unique values
    Cells(1, LC + 1) = "Key"
    If Hdrs = 6 Then
        off = True
        FR = 2
    Else
        FR = 1
    End If

    For Col = 1 To LC Step Cols
        Range(Cells(FR, Col - 1 + SrtCol), Cells(Rows.Count, Col - 1 + SrtCol)).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 if needed
    If Hdrs = 6 Then
        With Range(Cells(1, LC + 3), Cells(1, LC + 2 + LC))
            .Formula = "=INDEX(1:1, COLUMN(A1))"
            .Value = .Value
        End With
    End If
   
'Fill in new table values
    LR = Cells(Rows.Count, LC + 2).End(xlUp).Row
    On Error Resume Next
   
    For Col = 1 To LC Step Cols
        Set vRNG = Columns(Col - 1 + SrtCol).SpecialCells(xlConstants)
        For Each v In vRNG
            Set vFND = Columns(LC + 2).Find(v, LookIn:=xlValues, LookAt:=xlWhole)
            If Not vFND Is Nothing Then
                If v.Row = 1 Then
                    If Not off Then v.Resize(, Cols).Copy vFND.Offset(, Col)
                Else
                    v.Offset(, 1 - SrtCol).Resize(, Cols).Copy vFND.Offset(, Col)
                End If
            End If
        Next v
    Next Col

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

End Sub

 


Nothing says "thanks" like a steak dinner!
PayPal - The safer, easier way to pay online!

Comments