VBA Line up 3 Columns

A

anthonyexcel

Active Member
Joined
Jun 10, 2011
Messages
258
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

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
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
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
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

G
  • Question
Using Excel formula to create HTML code text referencing specific cells
Replies
0
Views
816
gvsumich
G
C
  • Solved
Excel 2016 32bit VBA Pulling info from Website to Sheet
Replies
2
Views
1K
CrashOD
C
E
  • Question
Query in excel to Outlook mail take rows with name until next name
Replies
0
Views
343
esben
E
E
  • Question
Create mails with table - standard header specific row
Replies
1
Views
925
esben
E
M
  • Question
Build HTML Table based on Loop through Excel Worksheet Column / Row condition
Replies
0
Views
751
mystik5
M

Forum statistics

Threads
1,214,527
Messages
6,120,058
Members
448,940
Latest member
mdusw

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