From heading levels in columns to vertical (indented) textflow

htham

New Member
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:

MickG

MrExcel MVP
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
 

htham

New Member
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!
 

htham

New Member
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
 

MickG

MrExcel MVP
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.
 

htham

New Member
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 ;)
 

htham

New Member
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
 

MickG

MrExcel MVP
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:

htham

New Member
Try this :-
The code Results should now be in Column "A" without Blank rows and Indented (Hopefully)
Works perfectly, thanks!

Can I mark the thread as solved?
 
Last edited:

Some videos you may like

This Week's Hot Topics

Top