VBA Line up 3 Columns

A

anthonyexcel

Active Member
Joined
Jun 10, 2011
Messages
256
Office Version
  1. 365
Platform
  1. Windows
I have 3 sets of data that I need to line up. The columns are all sorted in alphabetical order . Please see below:
<style type="text/css">
table.tableizer-table {
border: 1px solid #CCC; font-family: Arial, Helvetica, sans-serif;
font-size: 12px;
}
.tableizer-table td {
padding: 4px;
margin: 3px;
border: 1px solid #ccc;
}
.tableizer-table th {
background-color: #104E8B;
color: #FFF;
font-weight: bold;
}
</style>







Business Group ASales Business Group BSales Business Group CSales
A23 B86 D67
D5 C65 L8
G4 D453 M4
H65 I34 W2
K76 L23 X7
L87 M23 Z1

<tbody>
</tbody>


I need this:
<style type="text/css">
table.tableizer-table {
border: 1px solid #CCC; font-family: Arial, Helvetica, sans-serif;
font-size: 12px;
}
.tableizer-table td {
padding: 4px;
margin: 3px;
border: 1px solid #ccc;
}
.tableizer-table th {
background-color: #104E8B;
color: #FFF;
font-weight: bold;
}
</style>














Business Group ASales Business Group BSales Business Group CSales
A23
B86
C65
D5 D453 D67
G4
H65
I34
K76
L87 L23 L8
M23 M4
W2
X7
Z1

<tbody>
</tbody>


Thanks in advance!
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
Your Data in columns "A,B" "D,E" and "G,H".
Results will overwright this data.
Code: 
[COLOR=Navy]Sub[/COLOR] MG23May41
[COLOR=Navy]Dim[/COLOR] RngA [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, Q [COLOR=Navy]As[/COLOR] Variant, Ac [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] RngD [COLOR=Navy]As[/COLOR] Range, RngG [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] K [COLOR=Navy]As[/COLOR] Variant, G [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Set[/COLOR] RngA = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR=Navy]Set[/COLOR] RngD = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
[COLOR=Navy]Set[/COLOR] RngG = Range(Range("G2"), Range("G" & Rows.Count).End(xlUp))
[COLOR=Navy]Set[/COLOR] Rng = Union(RngA, RngD, RngG)
    [COLOR=Navy]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
    For Each Dn In Rng 
        [COLOR=Navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
            .Add Dn.Value, Dn
        [COLOR=Navy]Else[/COLOR]
            [COLOR=Navy]Set[/COLOR] .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR] Dn


ReDim nray(1 To Rng.Count, 1 To 8)
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] K [COLOR=Navy]In[/COLOR] .keys
        c = c + 1: Ac = 1
        [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] G [COLOR=Navy]In[/COLOR] .Item(K)
            nray(c, Ac) = G
            nray(c, Ac + 1) = G.Offset(, 1)
            Ac = Ac + 3
        [COLOR=Navy]Next[/COLOR] G
    [COLOR=Navy]Next[/COLOR] K
[COLOR=Navy]End[/COLOR] With


 Rng(1).Resize(Rng.Rows.Count, 8).ClearContents
  [COLOR=Navy]With[/COLOR] Range("A2").Resize(c, 8)
     .Value = nray
     .Sort Range("A2"), xlAscending
[COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
Mick thanks for the reply, when I run your code this is what I get below:
<style type="text/css">
table.tableizer-table {
border: 1px solid #CCC; font-family: Arial, Helvetica, sans-serif;
font-size: 12px;
}
.tableizer-table td {
padding: 4px;
margin: 3px;
border: 1px solid #ccc;
}
.tableizer-table th {
background-color: #104E8B;
color: #FFF;
font-weight: bold;
}
</style>














Business Group ASales Business Group BSales Business Group CSales
A23
B86
C65
D5 D453 D67
G4
H65
I34
K76
L87 L23 L8
M23 M4
W2
X7
Z1

<tbody>
</tbody>


What I really need is to show it like my 2nd example because I need to show it by group. Thanks.
 
Upvote 0
ADVERTISEMENT
There's a workbook at https://app.box.com/shared/elrnbidnr7 that will convert your example as shown:

Row\Col
A​
B​
C​
D​
E​
F​
G​
H​
1​
Group A​
Sales​
​
Group B​
Sales​
​
Group C​
Sales​
2​
A
23​
3​
B
86​
4​
C
65​
5​
D
5​
D
453​
D
67​
6​
G
4​
7​
H
65​
8​
I
34​
9​
K
76​
10​
L
87​
L
23​
L
8​
11​
M
23​
M
4​
12​
W
2​
13​
X
7​
14​
Z
1​
 
Upvote 0
Hi,

This will convert your example. Assumes that data starts in Cell A1 with "Business Group A".

Code: 
Sub instosort()

    Dim a1 As Integer
    Dim a2 As Integer
    Dim a3 As Integer
    Dim alpha As String
    Dim i As Integer
    Dim rowct As Single

    i = 2
    rowct = 0
    Do Until a1 + a2 + a3 = 1500
    On Error Resume Next
        a1 = 500
        a2 = 500
        a3 = 500
        a1 = Asc(Cells(i, 1).Value)
        a2 = Asc(Cells(i, 4).Value)
        a3 = Asc(Cells(i, 7).Value)
            If a1 = a2 And a2 = a3 Then GoTo skip
            If a1 < a2 And a1 <> 500 Then
                Range(Cells(i, 4), Cells(i, 5)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
                End If
            If a1 < a3 And a1 <> 500 Then
                Range(Cells(i, 7), Cells(i, 8)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
            End If
            If a2 < a1 And a2 < a3 And a1 <> 500 Then
                Range(Cells(i, 1), Cells(i, 2)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
                Range(Cells(i, 7), Cells(i, 8)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
            End If
            If a2 < a3 And a2 < a1 And a2 <> 500 Then
                Range(Cells(i, 1), Cells(i, 2)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
                Range(Cells(i, 7), Cells(i, 8)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
            End If
            If a3 < a2 And a3 < a1 And a2 <> 500 And a1 <> 500 Then
                Range(Cells(i, 1), Cells(i, 2)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
                Range(Cells(i, 4), Cells(i, 5)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
            End If
            If a1 > a2 And a1 > a3 And a1 <> 500 Then
                Range(Cells(i, 1), Cells(i, 2)).Insert shift:=xlDown
            End If
skip:
       rowct = 0
       i = i + 1
    Loop

End Sub

igold
 
Upvote 0
ADVERTISEMENT
Ah, a slight adjustment...

Code: 
Sub instosort()

    Dim a1 As Integer
    Dim a2 As Integer
    Dim a3 As Integer
    Dim alpha As String
    Dim i As Integer
    Dim rowct As Single

    i = 2
    rowct = 0
    Do Until a1 + a2 + a3 = 1500
    On Error Resume Next
        a1 = 500
        a2 = 500
        a3 = 500
        a1 = Asc(Cells(i, 1).Value)
        a2 = Asc(Cells(i, 4).Value)
        a3 = Asc(Cells(i, 7).Value)
            If a1 = a2 And a2 = a3 Then GoTo skip
            If a1 < a2 And a1 <> 500 Then
                Range(Cells(i, 4), Cells(i, 5)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
                End If
            If a1 < a3 And a1 <> 500 Then
                Range(Cells(i, 7), Cells(i, 8)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
            End If
            If a2 < a1 And a2 < a3 And a1 <> 500 Then
                Range(Cells(i, 1), Cells(i, 2)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
                Range(Cells(i, 7), Cells(i, 8)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
            End If
            If a2 < a3 And a2 < a1 And a2 <> 500 Then
                Range(Cells(i, 1), Cells(i, 2)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
                Range(Cells(i, 7), Cells(i, 8)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
            End If
            If a3 < a2 And a3 < a1 Then
                Range(Cells(i, 1), Cells(i, 2)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
                Range(Cells(i, 4), Cells(i, 5)).Insert shift:=xlDown
                rowct = rowct + 1
                If rowct = 2 Then GoTo skip
            End If
            If a1 > a2 And a1 > a3 And a1 <> 500 Then
                Range(Cells(i, 1), Cells(i, 2)).Insert shift:=xlDown
            End If
skip:
       rowct = 0
       i = i + 1
    Loop

End Sub

I would have edited my original post but got caught by the time limit...

igold
 
Upvote 0
This code appears to do what you asked for...
Code: 
Sub LineUpBusinessGroups()
  Dim R As Long, 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))
    If Cells(R, "A") > MinText Then Cells(R, "A").Resize(, 2).Insert xlShiftDown
    If Cells(R, "D") > MinText Then Cells(R, "D").Resize(, 2).Insert xlShiftDown
    If Cells(R, "G") > MinText Then Cells(R, "G").Resize(, 2).Insert xlShiftDown
    R = R + 1
  Loop
  Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Thank you all for your help. I appreciate all the help and guidance. Thanks you all again. The information is fantastic.
 
Upvote 0
Seems I got up a bit too late today to catch the worm !!!
The code below is now modified, to show your require result, and not the one I was originally working to, (pasting error)
Code: 
[COLOR="Navy"]Sub[/COLOR] MG24May04
[COLOR="Navy"]Dim[/COLOR] RngA [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, Q [COLOR="Navy"]As[/COLOR] Variant, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] RngD [COLOR="Navy"]As[/COLOR] Range, RngG [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, G [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] RngA = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] RngD = Range(Range("D2"), Range("D" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] RngG = Range(Range("G2"), Range("G" & Rows.Count).End(xlUp))
[COLOR="Navy"]Set[/COLOR] Rng = Union(RngA, RngD, RngG)
    [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            Dic.Add Dn.Value, Dn
        [COLOR="Navy"]Else[/COLOR]
            [COLOR="Navy"]Set[/COLOR] Dic.Item(Dn.Value) = Union(Dic.Item(Dn.Value), Dn)
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn


ReDim nray(1 To Rng.Count, 1 To 8)
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
        c = c + 1: Ac = 1
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] Dic.Item(K)
            nray(c, Ac) = G
            nray(c, Ac + 1) = G.Offset(, 1)
            Ac = Ac + 3
        [COLOR="Navy"]Next[/COLOR] G
    [COLOR="Navy"]Next[/COLOR] K


Rng(1).Resize(Rng.Rows.Count, 8).ClearContents
  [COLOR="Navy"]With[/COLOR] Range("A2").Resize(c, 8)
     .Value = nray
     .Sort Range("A2"), xlAscending
[COLOR="Navy"]End[/COLOR] With
c = 0
[COLOR="Navy"]Set[/COLOR] RngA = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    ReDim Ray(1 To RngA.Count, 1 To 8)
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] RngA
        c = c + 1
        [COLOR="Navy"]Set[/COLOR] nRng = Range(Cells(Dn.Row, 1), Cells(Dn.Row, Columns.Count).End(xlToLeft))
        [COLOR="Navy"]For[/COLOR] n = 1 To nRng.Count
            Ray(c, n + Dic.Item(Dn.Value).Column - 1) = nRng(, n)
        [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] Dn
Range("A2").Resize(RngA.Count, 8) = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Counting Asterisks
Replies
8
Views
561
PCL
PCL
muhammad susanto
  • Question
Pull Data Based On Header
Replies
4
Views
717
mohadin
M
S
  • Question
Counting Columns of x
Replies
8
Views
977
anthonyexcel
A
S
  • Question
Count Areas with a formula
Replies
2
Views
577
Stephen_IV
S
muhammad susanto
  • Question
Automatic Sort Number From Small
Replies
2
Views
1K
muhammad susanto
muhammad susanto

Forum statistics

Threads
1,196,367
Messages
6,014,848
Members
441,850
Latest member
peh16

Share this page

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