Rick Rothstein
05-25-2015, 03:07 AM
I responded recently to the following question from someone in a different forum...
I have 3 sets of data that I need to line up. The columns are all sorted in alphabetical order . Please see below:
Business Group A
Sales
Business Group B
Sales
Business Group C
Sales
A
23
B
86
D
67
D
5
C
65
L
8
G
4
D
453
M
4
H
65
I
34
W
2
K
76
L
23
X
7
L
87
M
23
Z
1
I need this:
Business Group A
Sales
Business Group B
Sales
Business Group C
Sales
A
23
B
86
C
65
D
5
D
453
D
67
G
4
H
65
I
34
K
76
L
87
L
23
L
8
M
23
M
4
W
2
X
7
Z
1
My solution was somewhat compact...
Sub LineUpBusinessGroups()
Dim R As Long, C As Variant, MinText As String
R = 2
Application.ScreenUpdating = False
Do While Application.CountA(Cells(R, "A"), Cells(R, "D"), Cells(R, "G")) > 0
MinText = Evaluate(Replace("IF(IF(A#&""zzz""< D#&""zzz"",A#&""zzz""," & _
"D#&""zzz"")< G#&""zzz"",IF(A#&""zzz""< D#&""zzz""," & _
"A#&""zzz"",D#&""zzz""),G#&""zzz"")", "#", R))
For Each C In Array("A", "D", "G")
If Cells(R, C) > MinText Then Cells(R, C).Resize(, 2).Insert xlShiftDown
Next
R = R + 1
Loop
Application.ScreenUpdating = True
End Sub
But I got to thinking about this question in its more general sense... What if there were more columns within each group? What if the offset between groups was different? What if the "table" of data did not start on Row 1 or in Column A? What if the data were not pre-sorted? What if the column used for aligning the groups was not the first column in the group (perhaps the first column in the group was a date column followed by a name column followed by data columns)? So I decided to create a generalized routine that the user can pass the structure of the data into as arguments. Here is what I came up with (not anywhere as compact as my solution to the specific question asked originally, but to be expected when coding for a user-specified general setup)...
Sub SortAndAlignGroups(GroupStartCell As Range, GroupOffset As Long, ColsPerGroup As Long, _
Optional CompareColOffset As Long = 0, Optional HasHeader As Boolean = True, _
Optional LastCol As Variant = 0, Optional SpacedRows As Boolean = False)
Dim R As Long, C As Long, StartCol As Long, GroupsCount As Long
Dim CompareStartCell As Long, MinText As String
StartCol = GroupStartCell.Offset(, CompareColOffset).Column
If LastCol = 0 Then
LastCol = Cells(GroupStartCell.Row, Columns.Count).End(xlToLeft).Column
Else
LastCol = Cells(GroupStartCell.Row, LastCol).Column
End If
R = GroupStartCell.Row - HasHeader
Application.ScreenUpdating = False
For C = StartCol To LastCol Step GroupOffset
Cells(R, C).Resize(Rows.Count - R, ColsPerGroup).Sort Cells(R, C + CompareColOffset), Header:=xlNo
Next
Do While Application.CountA(Rows(R)) > 0
MinText = ""
For C = StartCol To LastCol Step GroupOffset
If MinText = "" And Cells(R, C) <> "" Then
MinText = Cells(R, C)
ElseIf Cells(R, C) < MinText And Cells(R, C) <> "" Then
MinText = Cells(R, C)
End If
Next
For C = StartCol To LastCol Step GroupOffset
If Cells(R, C) > MinText Then
Cells(R, C - CompareColOffset).Resize(1 - SpacedRows, ColsPerGroup).Insert xlShiftDown
ElseIf SpacedRows Then
Cells(R - SpacedRows, C - CompareColOffset).Resize(1, ColsPerGroup).Insert xlShiftDown
End If
Next
R = R - SpacedRows + 1
Loop
Application.ScreenUpdating = True
End Sub
Here is a description for each of the arguments...
GroupStartCell - This is a range reference to the first cell in the data table.
GroupOffset - This is the column offset between groups (using the first table above, this value would be set as 3 since Column D is three columns to the right of Column A... the offsets between groups is always going to be the same).
ColsPerGroup - This is the number of columns making up a single group. This argument coupled with the first two arguments above allows you to work with multiple groups with zero or more blank columns between the groups.
CompareColOffset- This argument is optional and sets the offset from the group's first column to the column which the data will be aligned on. The default for this argument is 0 meaning the first column in the group will be used for aligning the groups.
HasHeader- This argument is optional and tells the code whether to ignore the first row or not. The default for this argument is True meaning the code will assume there is a header and ignore it.
LastCol- This argument is optional and, if specified, should be set to the last column of the last group (it can be specified as the column number or the quoted column letter designation). Being able to specify a last column allows for additional data to exist to the right of the data being aligned... that data, as well as any data to the left of the cell reference specified in the first argument, will not be touched or moved. The default for this argument when omitted is 0 meaning the code will calculate the last column in the last group on the assumption that there is not data to the right of it.
SpacedRows- This argument is optional and, if set to True, will place a blank row between each row outputted. The default is False meaning no separator rows will be inserted.
Whoops, I almost forgot to mention... this is a subroutine, not a macro, so it needs to be called from within other VB code. For the question that led to this article (see the two tables at the beginning of this article), the call to my subroutine would look like this (no optional arguments are specified)...
SortAndAlignGroups Range("A1"), 3, 2
I am not sure if anyone will actually find a need for this routine, but I found the extended question it answer somewhat intriguing, which is the main reason I created the code. Not wanting to waste the effort it took to write it, I figured I might as well post it here just in case someone at some time in the future might find it useful.
EDIT NOTE: I forgot to mention when I first posted this (apologies to the 7 people who have already viewed this article), you do not have sort your data before calling this routine... it will automatically sort each group individually according to the specified compare column.
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwTUdEgR4bdt6crKXF4AaABAg.9xmkXGSciKJ9xonTti2s Ix (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwTUdEgR4bdt6crKXF4AaABAg.9xmkXGSciKJ9xonTti2s Ix)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwWw16qBFX39JCRRm54AaABAg.9xnskBhPnmb9xoq3mGxu _b (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwWw16qBFX39JCRRm54AaABAg.9xnskBhPnmb9xoq3mGxu _b)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9xon1p2ImxO (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9xon1p2ImxO)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgybZfNJd3l4FokX3cV4AaABAg.9xm_ufqOILb9xooIlv5P LY (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgybZfNJd3l4FokX3cV4AaABAg.9xm_ufqOILb9xooIlv5P LY)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9y38bzbSqaG (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9y38bzbSqaG)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgyWm8nL7syjhiHtpBF4AaABAg.9xmt8i0IsEr9y3FT9Y9F eM (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgyWm8nL7syjhiHtpBF4AaABAg.9xmt8i0IsEr9y3FT9Y9F eM)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9xpn-GDkL3o (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9xpn-GDkL3o)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNsaS3Lp1 (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNsaS3Lp1)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgR1EPUkhw (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgR1EPUkhw)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNe_XC-jK (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNe_XC-jK)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNPOdiDuv (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNPOdiDuv)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgN7AC7wAc (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgN7AC7wAc)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
I have 3 sets of data that I need to line up. The columns are all sorted in alphabetical order . Please see below:
Business Group A
Sales
Business Group B
Sales
Business Group C
Sales
A
23
B
86
D
67
D
5
C
65
L
8
G
4
D
453
M
4
H
65
I
34
W
2
K
76
L
23
X
7
L
87
M
23
Z
1
I need this:
Business Group A
Sales
Business Group B
Sales
Business Group C
Sales
A
23
B
86
C
65
D
5
D
453
D
67
G
4
H
65
I
34
K
76
L
87
L
23
L
8
M
23
M
4
W
2
X
7
Z
1
My solution was somewhat compact...
Sub LineUpBusinessGroups()
Dim R As Long, C As Variant, MinText As String
R = 2
Application.ScreenUpdating = False
Do While Application.CountA(Cells(R, "A"), Cells(R, "D"), Cells(R, "G")) > 0
MinText = Evaluate(Replace("IF(IF(A#&""zzz""< D#&""zzz"",A#&""zzz""," & _
"D#&""zzz"")< G#&""zzz"",IF(A#&""zzz""< D#&""zzz""," & _
"A#&""zzz"",D#&""zzz""),G#&""zzz"")", "#", R))
For Each C In Array("A", "D", "G")
If Cells(R, C) > MinText Then Cells(R, C).Resize(, 2).Insert xlShiftDown
Next
R = R + 1
Loop
Application.ScreenUpdating = True
End Sub
But I got to thinking about this question in its more general sense... What if there were more columns within each group? What if the offset between groups was different? What if the "table" of data did not start on Row 1 or in Column A? What if the data were not pre-sorted? What if the column used for aligning the groups was not the first column in the group (perhaps the first column in the group was a date column followed by a name column followed by data columns)? So I decided to create a generalized routine that the user can pass the structure of the data into as arguments. Here is what I came up with (not anywhere as compact as my solution to the specific question asked originally, but to be expected when coding for a user-specified general setup)...
Sub SortAndAlignGroups(GroupStartCell As Range, GroupOffset As Long, ColsPerGroup As Long, _
Optional CompareColOffset As Long = 0, Optional HasHeader As Boolean = True, _
Optional LastCol As Variant = 0, Optional SpacedRows As Boolean = False)
Dim R As Long, C As Long, StartCol As Long, GroupsCount As Long
Dim CompareStartCell As Long, MinText As String
StartCol = GroupStartCell.Offset(, CompareColOffset).Column
If LastCol = 0 Then
LastCol = Cells(GroupStartCell.Row, Columns.Count).End(xlToLeft).Column
Else
LastCol = Cells(GroupStartCell.Row, LastCol).Column
End If
R = GroupStartCell.Row - HasHeader
Application.ScreenUpdating = False
For C = StartCol To LastCol Step GroupOffset
Cells(R, C).Resize(Rows.Count - R, ColsPerGroup).Sort Cells(R, C + CompareColOffset), Header:=xlNo
Next
Do While Application.CountA(Rows(R)) > 0
MinText = ""
For C = StartCol To LastCol Step GroupOffset
If MinText = "" And Cells(R, C) <> "" Then
MinText = Cells(R, C)
ElseIf Cells(R, C) < MinText And Cells(R, C) <> "" Then
MinText = Cells(R, C)
End If
Next
For C = StartCol To LastCol Step GroupOffset
If Cells(R, C) > MinText Then
Cells(R, C - CompareColOffset).Resize(1 - SpacedRows, ColsPerGroup).Insert xlShiftDown
ElseIf SpacedRows Then
Cells(R - SpacedRows, C - CompareColOffset).Resize(1, ColsPerGroup).Insert xlShiftDown
End If
Next
R = R - SpacedRows + 1
Loop
Application.ScreenUpdating = True
End Sub
Here is a description for each of the arguments...
GroupStartCell - This is a range reference to the first cell in the data table.
GroupOffset - This is the column offset between groups (using the first table above, this value would be set as 3 since Column D is three columns to the right of Column A... the offsets between groups is always going to be the same).
ColsPerGroup - This is the number of columns making up a single group. This argument coupled with the first two arguments above allows you to work with multiple groups with zero or more blank columns between the groups.
CompareColOffset- This argument is optional and sets the offset from the group's first column to the column which the data will be aligned on. The default for this argument is 0 meaning the first column in the group will be used for aligning the groups.
HasHeader- This argument is optional and tells the code whether to ignore the first row or not. The default for this argument is True meaning the code will assume there is a header and ignore it.
LastCol- This argument is optional and, if specified, should be set to the last column of the last group (it can be specified as the column number or the quoted column letter designation). Being able to specify a last column allows for additional data to exist to the right of the data being aligned... that data, as well as any data to the left of the cell reference specified in the first argument, will not be touched or moved. The default for this argument when omitted is 0 meaning the code will calculate the last column in the last group on the assumption that there is not data to the right of it.
SpacedRows- This argument is optional and, if set to True, will place a blank row between each row outputted. The default is False meaning no separator rows will be inserted.
Whoops, I almost forgot to mention... this is a subroutine, not a macro, so it needs to be called from within other VB code. For the question that led to this article (see the two tables at the beginning of this article), the call to my subroutine would look like this (no optional arguments are specified)...
SortAndAlignGroups Range("A1"), 3, 2
I am not sure if anyone will actually find a need for this routine, but I found the extended question it answer somewhat intriguing, which is the main reason I created the code. Not wanting to waste the effort it took to write it, I figured I might as well post it here just in case someone at some time in the future might find it useful.
EDIT NOTE: I forgot to mention when I first posted this (apologies to the 7 people who have already viewed this article), you do not have sort your data before calling this routine... it will automatically sort each group individually according to the specified compare column.
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwTUdEgR4bdt6crKXF4AaABAg.9xmkXGSciKJ9xonTti2s Ix (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwTUdEgR4bdt6crKXF4AaABAg.9xmkXGSciKJ9xonTti2s Ix)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwWw16qBFX39JCRRm54AaABAg.9xnskBhPnmb9xoq3mGxu _b (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgwWw16qBFX39JCRRm54AaABAg.9xnskBhPnmb9xoq3mGxu _b)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9xon1p2ImxO (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9xon1p2ImxO)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgybZfNJd3l4FokX3cV4AaABAg.9xm_ufqOILb9xooIlv5P LY (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgybZfNJd3l4FokX3cV4AaABAg.9xm_ufqOILb9xooIlv5P LY)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9y38bzbSqaG (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgzgWvzV-kvC4TJ8O414AaABAg.9xnFzCj8HRM9y38bzbSqaG)
https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgyWm8nL7syjhiHtpBF4AaABAg.9xmt8i0IsEr9y3FT9Y9F eM (https://www.youtube.com/watch?v=XQAIYCT4f8Q&lc=UgyWm8nL7syjhiHtpBF4AaABAg.9xmt8i0IsEr9y3FT9Y9F eM)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9xpn-GDkL3o (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9xpn-GDkL3o)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNsaS3Lp1 (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNsaS3Lp1)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgR1EPUkhw (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgR1EPUkhw)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNe_XC-jK (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNe_XC-jK)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNPOdiDuv (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgNPOdiDuv)
https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgN7AC7wAc (https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wgN7AC7wAc)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)