Auto Grouping - VBA

[MahanK]

Hi All,

Can you please help me to make a dynamic grouping sheet by Macro. If you look at my attached file, I have added one column (H) to calculate space before the first string and put conditional format on it. actually I'm trying to group whole the rows based on column'A', that's why I have added the column K. I don't know how to group them as it is shown on excel. beside I have copy and Pastethese data from P6. cause I need to do it every week, I'm looking for a dynamic and quick way with least admin time.
I would be really appreciate if you help me in this regard.

 

[MahanK]

Any Suggestion Folks ?

 

[p45cal]

In the attached, a button which calls this macro:

Sub blah()
Range("A1").ClearOutline
Set dict = CreateObject("Scripting.Dictionary")
Set myData = Range("A1").CurrentRegion.Resize(, 7)
Set rngFormulae = myData.Offset(, myData.Columns.Count + 3).Resize(, 1)
rngFormulae.FormulaR1C1 = "=FIND(LEFT(TRIM(RC[-10]),1),RC[-10])-1"
Rows(1).Insert
rngFormulae.Cells(1).Offset(-1).Value = "zzz"
On Error Resume Next
For Each cll In rngFormulae.Cells
  dict.Add CStr(cll.Value), cll.Value
Next cll
On Error GoTo 0
myarray = dict.items
For i = 2 To dict.Count
  rngFormulae.Offset(-1).Resize(rngFormulae.Cells.Count + 1).AutoFilter Field:=1, Criteria1:=">" & Application.WorksheetFunction.Large(myarray, i)
  For Each are In myData.SpecialCells(xlCellTypeVisible).Areas
    are.Rows.Group
  Next are
Next i
Rows(1).Delete
rngFormulae.ClearContents
End Sub

Is it right?

 

[MahanK]

Yes that's great thanks you so much. I'm wondering if it is possible when I choose a lowest level activity on filter, It comes up with the its higher levels? if it is possible to stick the higher level to the lower level ?

 

[MahanK]

also is it compatiable with all range of data, cause I try it with longer data but it seems not right on some levels ?

 

[p45cal]

1. Supply the file you attached in msg#1 but with the grouping manually applied as you want it.
2. Also add a sheet with longer data where my code doesn't seem to work.

 

[MahanK]

Thanks for Replying,
I have uploaded a file that I created. the first tab is what I'm trying to present it and tab 2 is the original data. I have added a column in the first tab that is called index in order to count space from the first string then found a VBA and applied it to this sheet it seemed worked fine but since I added more data from other project as you can see, it does not group properly and also the offshore construction level does not role up. can you please have a look at my sheet and propose a solution for unlimited amount of data. my current macro seems not working for every range of data. and is it possible to freez level 4 to level 2 and level zero so if I filter one job on level 0 all the lower level comes up ?

 

[p45cal]

I've tweaked my blah macro code to accommodate your wider data and when run it produces the same grouping as the grouping in your most recently attached file (actually fewer group levels but one of your groups is grouping blank rows unnecessarily); is your grouping there as you want it to be?
If not supply a file with grouping manually applied as you want it (I suggest you use your smaller data sample to do this) because I don't understand at all what you mean by: "and is it possible to freez level 4 to level 2 and level zero so if I filter one job on level 0 all the lower level comes up ?". If you can do this manually, it should be possible to replicate this in code.

 

[MahanK]

Yes it is exactly what I was looking for thank you so much. actually I had a problem with filtering after grouping the data. when I filter an specific data from level 3 I wanted to see the level 2 and level 1 of that like what we're able to do at Pivot Table. but I tricked it with a customized column and filter that column in order to see the parent group.

 

[p45cal]

Attached has a button on the sheet original data which runs the new blah macro which first copies the original data sheet and works on that copy leaving the original sheet un touched.
The code is:

Sub blah()
CopySheet
With ActiveSheet
  .Buttons("Button 1").Delete
  .Range("A1").ClearOutline
  Set dict = CreateObject("Scripting.Dictionary")
  Set myData = .Range("A1").CurrentRegion
  .Columns(1).Insert
  Set rngFormulae = myData.Offset(, -1).Resize(, 1)
  rngFormulae.FormulaR1C1 = "=FIND(LEFT(TRIM(RC[1]),1),RC[1])-1"    '"=FIND(LEFT(TRIM(RC[-15]),1),RC[-15])-1" '"=FIND(LEFT(TRIM(RC[-10]),1),RC[-10])-1"
  rngFormulae.Cells(1).Value = "zzz"
  On Error Resume Next
  For Each cll In Intersect(rngFormulae, rngFormulae.Offset(1)).Cells
    dict.Add CStr(cll.Value), cll.Value
  Next cll
  On Error GoTo 0
  myarray = dict.items
  For i = 2 To dict.Count
    rngFormulae.AutoFilter Field:=1, Criteria1:=">" & Application.WorksheetFunction.Large(myarray, i)
    For Each are In myData.SpecialCells(xlCellTypeVisible).Areas
      are.Rows.Group
    Next are
  Next i
  .Columns(1).Delete
End With
End Sub


Sub CopySheet()
    Sheets("original data ").Copy After:=Sheets(Sheets.Count)
End Sub

But you already have the macro GroupBasedOnLevel which seems to do something similar.

 

[ali raza]

Its really an awesome code to auto group outline. I am facing a little problem with the code because in this code its drilling the data downwards and in my case its upward. for example in below data i want grouping on totals. Please help me to achieve this with same code as i might extend this into next level which is price range and actual price.

Department	Category	Sub-category
A	AB	ABA
A	AB	ABA Total
A	AB	ABB
A	AB	ABB Total
A	AB Total
A	AC	ACA
A	AC	ACA Total
A	AC	ACB
A	AC	ACB
A	AC	ACB Total
A	AC Total
A Total