From heading levels in columns to vertical (indented) textflow

htham

New Member
Joined
Oct 25, 2014
Messages
6
Hi,

Short version:
Someone knows about a VBA way to structure data under indented parent-tree when parent name is on same row in columns to the left? (Se bottom example)

Long version:
This is my first post here so please let me know if I'm writing this wrong. (Tried to read rules and search for similair posts before writing this). Just started working with excel professionally an digging up old VBA knowledge and learning powerpivot/powerquery etc. so will probably be more posts ;)

I have a excel source file containing a WBS-visualization (Merged cells) that I need to transfer to MS project. By using PowerQuery I have managed to order the data according to the example in the end of this post.
Although in order to import it to MS project I need to have subtasks under their summaries and preferable indented.
Since source data is approx 2000 rows I'm looking for a way to reduce the manual labor to achieve this.

Maybe there is away to use VBA to order the data in one column and under their summaries?
Source data is now structured so that first level is in column A, second level in B...

Best regards

Henrik Tham

Current status: (Also have "unfilled version" with empty cells until next change)
A-grandgrandparentB-grandparentC-parentD-ChildE-optional infant
A1B1C1D1
A1B1C1D2
A1B1C2D3E1
A1B1C2D3E2
A1B2C3D4
A1B2C4D5
A2B3C5D6

<tbody>
</tbody>

Preferred Outcome:
A1
-B1
--C1
---D1
---D2
--C2
---D3
----E1
----E2
-B2
--C3
---D4
--C4
---D5
A2
-B3
--C5
---D6

<tbody>
</tbody>
 
Last edited:

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Perhaps this:-
Data sheet1, Results sheet2
Code:
[COLOR="Navy"]Sub[/COLOR] MG25Oct57
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic1 [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] G [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
    Sheets("Sheet2").Columns("A:E").ClearContents
        Lst = Cells("1", Columns.Count).End(xlToLeft).Column
            Rng.Resize(, Lst).Copy Sheets("Sheet2").Range("A2")
                [COLOR="Navy"]Set[/COLOR] Dic1 = CreateObject("scripting.dictionary")
                    Dic1.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] Ac = Lst To 1 [COLOR="Navy"]Step[/COLOR] -1
        c = 0
        [COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
            [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
        [COLOR="Navy"]End[/COLOR] With
            ReDim ray(1 To Rng.Count * 5, 1 To Lst)
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
                [COLOR="Navy"]If[/COLOR] Ac = 1 [COLOR="Navy"]Then[/COLOR] nRw = Dn.Value Else nRw = Join(Application.Transpose(Application.Transpose(Dn.Resize(, Ac))), ",")
                    [COLOR="Navy"]If[/COLOR] Not Dic1.Exists(nRw) [COLOR="Navy"]Then[/COLOR]
                        Dic1.Add nRw, Dn
                    [COLOR="Navy"]Else[/COLOR]
                        [COLOR="Navy"]Set[/COLOR] Dic1.Item(nRw) = Union(Dic1.Item(nRw), Dn)
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]Next[/COLOR]


[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic1.keys
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] Dic1.Item(K)
        c = c + 1
        [COLOR="Navy"]For[/COLOR] n = 1 To Lst
            ray(c, n) = G.Offset(, n - 1)
        [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] G
[COLOR="Navy"]Next[/COLOR] K
    Sheets("Sheet2").Range("a2").Resize(c, Lst) = ray
    Dic1.RemoveAll
[COLOR="Navy"]Next[/COLOR] Ac
Call nFormatA(Lst)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]


[COLOR="Navy"]Sub[/COLOR] nFormatA(Lst)
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] pRay
[COLOR="Navy"]Dim[/COLOR] A [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oTemp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Stg [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Sp1 [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Sp2 [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] s [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] cc [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] F [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] StgTemp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
cc = Lst
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
pRay = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Resize(, Lst)
[COLOR="Navy"]End[/COLOR] With
ReDim Fray(1 To UBound(pRay, 1) * Lst, 1 To Lst)
[COLOR="Navy"]For[/COLOR] A = 1 To UBound(pRay, 1)
    [COLOR="Navy"]For[/COLOR] F = 1 To Lst
        Temp = Temp & "," & pRay(A, F)
        Temp = IIf(F = 1, Mid(Temp, 2), Temp)
    [COLOR="Navy"]Next[/COLOR] F
            
            [COLOR="Navy"]If[/COLOR] A = 1 [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]For[/COLOR] F = 1 To Lst
                        StgTemp = StgTemp & "," & pRay(A, F)
                        StgTemp = IIf(F = 1, Mid(StgTemp, 2), StgTemp)
                        Fray(F, F) = pRay(A, F)
                    [COLOR="Navy"]Next[/COLOR] F
                [COLOR="Navy"]Else[/COLOR]
                    Stg = ""
                    Sp1 = Split(oTemp, ",")
                    Sp2 = Split(Temp, ",")
                        [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp1)
                            [COLOR="Navy"]If[/COLOR] Not Sp1(n) = Sp2(n) Then: [COLOR="Navy"]Exit[/COLOR] For
                        [COLOR="Navy"]Next[/COLOR] n
                        [COLOR="Navy"]For[/COLOR] s = 0 To UBound(Sp1)
                            Stg = Stg & "," & Sp2(s)
                            [COLOR="Navy"]If[/COLOR] s >= n [COLOR="Navy"]Then[/COLOR]
                                cc = cc + 1
                                Fray(cc, s + 1) = Sp2(s)
                            [COLOR="Navy"]End[/COLOR] If
                        [COLOR="Navy"]Next[/COLOR] s
                [COLOR="Navy"]End[/COLOR] If
                oTemp = Temp
Temp = ""
[COLOR="Navy"]Next[/COLOR] A
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    .Select
    .Columns("A:E").ClearContents
    .Range("A1").Resize(, Lst).Value = Sheets("Sheet1").Range("A1").Resize(, Lst).Value
    .Range("A2").Resize(cc, Lst) = Fray
    .Range("A1").Activate
[COLOR="Navy"]End[/COLOR] With
MsgBox "Run"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Works like magic (almost) Thanks a lot!

Some small problems though:
Can't run it on all data since it runs into runtime error 9, subscript out of range
Debugger shows: Stg = Stg & "," & Sp2(s)
Works with 67 rows, but not with 90

Smaller problems for info only:
When there is no data it still adds an empty row, can just delete afterwords, no problem
Getting sheet 2 in several columns is nice but problematic for project, I can just replace empty with spaces and merge to on column, no problem

Again, thanks a lot!
 
Upvote 0
Can't run it on all data since it runs into runtime error 9, subscript out of range
Debugger shows: Stg = Stg & "," & Sp2(s)
Works with 67 rows, but not with 90

Found it! ;)

Noticed i had some cells with character "," first appearing in E69
Just did a replace all to ; and now it works on all data :D
 
Upvote 0
Good News !!!
Q:- Would I be right in thinking the actual format you require, is as sheet2 but with all data in just one column.
 
Upvote 0
Good News !!!
Q:- Would I be right in thinking the actual format you require, is as sheet2 but with all data in just one column.

That is correct, but i fixed it with a cell formula so no problem
Unfortunately MS-project didn't understand the indent so need some VBA code there as Well, but should manage that myself ;)
 
Upvote 0
Good News !!!
Q:- Would I be right in thinking the actual format you require, is as sheet2 but with all data in just one column.

That is correct, but i fixed it with a cell formula so no problem
Unfortunately MS-project didn't understand the indent so need some VBA code there as Well, but should manage that myself ;)

Now i found the info how it should be ordered, stupid not looking this up first...
Importing an Task Outline Structure into Project
It needs to be in two columns, the first one giving the outline level

So the final solution is (for reference is someone else has the same problem):

1. Replace all "," with other character not used
2. Run MickG:s code
3. Run a macro deleting empty rows
4. Replace all characters created in step one back to ","
5. Create one column giving the outline level based on column A-E containing data
6. Create one column with A-E concatenated
 
Upvote 0
Try this :-
The code Results should now be in Column "A" without Blank rows and Indented (Hopefully)
Code:
[COLOR="Navy"]Sub[/COLOR] MG26Oct39
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic1 [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] nRw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] G [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
    Sheets("Sheet2").Columns("A:E").ClearContents
        Lst = Cells("1", Columns.Count).End(xlToLeft).Column
            Rng.Resize(, Lst).Copy Sheets("Sheet2").Range("A2")
                [COLOR="Navy"]Set[/COLOR] Dic1 = CreateObject("scripting.dictionary")
                    Dic1.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] Ac = Lst To 1 [COLOR="Navy"]Step[/COLOR] -1
        c = 0
        [COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
            [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
        [COLOR="Navy"]End[/COLOR] With
            ReDim ray(1 To Rng.Count * 5, 1 To Lst)
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
                [COLOR="Navy"]If[/COLOR] Ac = 1 [COLOR="Navy"]Then[/COLOR] nRw = Dn.Value Else nRw = Join(Application.Transpose(Application.Transpose(Dn.Resize(, Ac))), ",")
                    [COLOR="Navy"]If[/COLOR] Not Dic1.Exists(nRw) [COLOR="Navy"]Then[/COLOR]
                        Dic1.Add nRw, Dn
                    [COLOR="Navy"]Else[/COLOR]
                        [COLOR="Navy"]Set[/COLOR] Dic1.Item(nRw) = Union(Dic1.Item(nRw), Dn)
                    [COLOR="Navy"]End[/COLOR] If
                [COLOR="Navy"]Next[/COLOR]


[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic1.keys
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] G [COLOR="Navy"]In[/COLOR] Dic1.Item(K)
        c = c + 1
        [COLOR="Navy"]For[/COLOR] n = 1 To Lst
            ray(c, n) = G.Offset(, n - 1)
        [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] G
[COLOR="Navy"]Next[/COLOR] K
    Sheets("Sheet2").Range("a2").Resize(c, Lst) = ray
    Dic1.RemoveAll
[COLOR="Navy"]Next[/COLOR] Ac
Call nFormatA(Lst)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]


[COLOR="Navy"]Sub[/COLOR] nFormatA(Lst)
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] pRay
[COLOR="Navy"]Dim[/COLOR] A [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oTemp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Stg [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Sp1 [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Sp2 [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] s [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] cc [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] F [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] StgTemp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
cc = Lst
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
pRay = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Resize(, Lst)
[COLOR="Navy"]End[/COLOR] With
ReDim Fray(1 To UBound(pRay, 1) * Lst, 1 To 1)
[COLOR="Navy"]For[/COLOR] A = 1 To UBound(pRay, 1)
    [COLOR="Navy"]For[/COLOR] F = 1 To Lst
        Temp = Temp & "," & pRay(A, F)
        Temp = IIf(F = 1, Mid(Temp, 2), Temp)
    [COLOR="Navy"]Next[/COLOR] F
            
            [COLOR="Navy"]If[/COLOR] A = 1 [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]For[/COLOR] F = 1 To Lst
                      [COLOR="Navy"]If[/COLOR] Not IsEmpty(pRay(A, F)) [COLOR="Navy"]Then[/COLOR]
                        c = c + 1
                        StgTemp = StgTemp & "," & pRay(A, F)
                        StgTemp = IIf(F = 1, Mid(StgTemp, 2), StgTemp)
                       '[COLOR="Green"][B]Change "4" in line below to alter Indent Size[/B][/COLOR]
                        Fray(c, 1) = Application.Rept(" ", c * 4) & pRay(A, F)
                        [COLOR="Navy"]End[/COLOR] If
                    [COLOR="Navy"]Next[/COLOR] F
                cc = c
                [COLOR="Navy"]Else[/COLOR]
                    Stg = ""
                    Sp1 = Split(oTemp, ",")
                    Sp2 = Split(Temp, ",")
                        [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp1)
                            [COLOR="Navy"]If[/COLOR] Not Sp1(n) = Sp2(n) Then: [COLOR="Navy"]Exit[/COLOR] For
                        [COLOR="Navy"]Next[/COLOR] n
                        [COLOR="Navy"]For[/COLOR] s = 0 To UBound(Sp1)
                            Stg = Stg & "," & Sp2(s)
                            [COLOR="Navy"]If[/COLOR] s >= n And Not Sp2(s) = "" [COLOR="Navy"]Then[/COLOR]
                                cc = cc + 1
                                '[COLOR="Green"][B]Change "4" in line below to alter Indent Size[/B][/COLOR]
                                Fray(cc, 1) = Application.Rept(" ", (s + 1) * 4) & Sp2(s)
                            [COLOR="Navy"]End[/COLOR] If
                        [COLOR="Navy"]Next[/COLOR] s
                [COLOR="Navy"]End[/COLOR] If
                oTemp = Temp
Temp = ""
[COLOR="Navy"]Next[/COLOR] A
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    .Select
    .Columns("A").Resize(, Lst).ClearContents
    [COLOR="Navy"]With[/COLOR] .Columns("A:A")
    .Font.Name = "Verdana"
    .Font.Size = 12
    [COLOR="Navy"]End[/COLOR] With
    .Range("A2").Resize(cc, 1) = Fray
    .Range("A1").Activate
[COLOR="Navy"]End[/COLOR] With
MsgBox "Run"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,513
Messages
6,114,072
Members
448,546
Latest member
KH Consulting

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