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 columns of data, I need to line up column B to column A and list non-matches separately"

SPECIFICATIONS:
1. Column A is untouched
2. Column B values are aligned where a match occurs
3. Non-matching column B values are retained and listed below
4. Columns A and B do not have to be the same length

#### CODE

Option Explicit

Sub LineEmUp5()
'Author:    Jerry Beaucaire
'Date:      8/4/2014
'Summary:   Line up Column B values with Column A values retaining original
'           order of column A.  Puts non-matching column B values below
Dim LR As Long

LR = Range("B" & Rows.Count).End(xlUp).Row      'last row of data in column B
With Range("E2:E" & LR)                         'list the non-matches in column E
.FormulaR1C1 = "=IF(NOT(ISNUMBER(MATCH(RC2,C1, 0))), RC2, """")"
.Value = .Value
End With

LR = Range("A" & Rows.Count).End(xlUp).Row      'last row of data in column A
With Range("D2:D" & LR)                         'list the aligned matches in column D
.FormulaR1C1 = "=IF(ISNUMBER(MATCH(RC1,C2, 0)), RC1,"""")"
.Value = .Value
End With

Range("D2:D" & LR).Copy Range("B2")             'copy aligned values into column B
'copy the non-matched value below column B
Range("E2:E" & Rows.Count).SpecialCells(xlConstants).Copy Range("B" & LR + 1)
Range("D:E").ClearContents                      'clear the helper columns D and E

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.  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, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Columns("F:H").Sort Key1:=Range("F2"), Order1:=xlAscending, _
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 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, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Columns("F:H").Sort Key1:=Range("F2"), Order1:=xlAscending, _
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 #5:
"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."

 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)
 A B C D E F G H I J K L 1 Code Rate Species Code Rate Species Code Rate Species Code Rate Species 2 abc123 4 cat abc123 5 hamster abc124 4 snake abc121 5 cat 3 abc124 5 dog abc125 3 dog abc127 5 bird abc123 3 lizard 4 abc127 3 bird abc126 4 lizard abc129 3 cat abc129 4 hamster 5 abc128 3 lizard abc127 5 cat abc122 3 dog abc127 5 bird

AFTER (matched by Species this time through)
 A B C D E F G H I J K L 1 Code Rate Species Code Rate Species Code Rate Species Code Rate Species 2 abc127 3 bird abc127 5 bird abc127 5 bird 3 abc123 4 cat abc127 5 cat abc129 3 cat abc121 5 cat 4 abc124 5 dog abc125 3 dog abc122 3 dog 5 abc123 5 hamster abc129 4 hamster 6 abc128 3 lizard abc126 4 lizard abc123 3 lizard 7 abc124 4 snake

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

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!