routine for group & outline in excel

[p27br]

hello

i have a sheet with data which follows the following format :

1 Top level
2 Level 2 line
3 Level 3 line
3 Level 3 line
2 Level 2 line
3 Level 3 line
3 Level 3 line
4 Level 4 line

the number of lines per level is variable

What I would like is for the grouping to occur in the following way

+ 1 Top level
| +2 Level 2 line
| | 3 Level 3 line
| | 3 Level 3 line
| -
| +2 Level 2 line
| |3 Level 3 line
| |3 Level 3 line
| -
-

any ideas ?
this is how it is now, but it does not give appropriate grouping

Sub doOutline(hierarchyDepth As Integer, lastRow As Long, objSheet As Worksheet, objApp As Excel.Application)
    Dim currentlevel As Long
    Dim ix As Long
    Dim topRow As Long
    Dim bottomrow As Long
    
    If hierarchyDepth > 0 Then
    For currentlevel = 1 To hierarchyDepth - 1 'number of groups
       ix = lastRow
       bottomrow = lastRow
       Do While ix > 3
         Do While Val(objSheet.Cells(ix, 1)) > currentlevel
            ix = ix - 1
         Loop
         topRow = ix + 1
         If bottomrow >= topRow Then
            objSheet.Activate
            objSheet.Rows(Format(topRow) & ":" & Format(bottomrow)).Select
            objApp.Selection.Rows.Group
         End If
         ix = ix - 1
         bottomrow = ix
       Loop
       
    Next currentlevel
    End If
End Sub

 

[GlennUK]

That routine is controlled by the values in the sheet. Are you using it correctly?

Cheers, Glenn.

Did you hear about the literalist show-jumper? He broke his nose jumping against the clock.

 

[p27br]

well, i'm not sure, that's why I was wondering if there may be another way, maybe a recursive function or something.

the first column in the sheet is always the level number.
ColA ColB
1 a description
2 a description

 

[AccordingToDale]

recursion is definitely the way to go. something like...

Sub doOutline(hierarchyDepth As Integer, lastRow As Long, _
      objSheet As Worksheet, objApp As Excel.Application, _
      testValue as long)

    Dim currentlevel As Long
    Dim ix As Long
    Dim topRow As Long
    Dim bottomrow As Long
    
    If hierarchyDepth > 0 Then
    For currentlevel = 1 To hierarchyDepth - 1 'number of groups
       ix = lastRow
       bottomrow = lastRow
       Do While ix > 3
         Do While Val(objSheet.Cells(ix, 1)) > currentlevel
            ix = ix - 1
         Loop
         topRow = ix + 1
         If bottomrow >= topRow Then
            objSheet.Activate
            objSheet.Rows(Format(topRow) & ":" & Format(bottomrow)).Select
            objApp.Selection.Rows.Group
         End If
         ix = ix - 1
         bottomrow = ix

         ''''START NEW CODE
         'you need to test some values -- probably here
         'not sure exactly what you're after

         if testValue > currentlevel then
           doOutline(hierarchyDepth, lastRow, objSheet, _ 
               objApp, testValue)
         else
           doOutline(hierarchyDepth, lastRow, objSheet, _ 
               objApp, currentlevel)
         end if

         'this of course will need some tweaking, but you
         'get the general gist....

         ''''END NEW CODE


       Loop
       
    Next currentlevel
    End If
End Sub

something like that. i'm not the best *recursive* thinker, but that's the general idea.

d

 

[GlennUK]

Hi p27br,

when you said "but it does not give appropriate grouping" ... can you tell us what happened?

Also how is your routine called? What are the values passed as the arguments?

I tried your routine, after hacking it to run stand-alone, and it worked fine.

Cheers, Glenn.

Did you hear about the literalist show-jumper? He broke his nose jumping against the clock.

 

[p27br]

hi
well instead of grouping like this

+ 1
| + 2
| | 3
| | 3
|
| + 2
| | 3

it groups like this
1
- 2
| - 3
| | 3
| |
| + 2
|
| | 3
+

so instead of the first 2 regrouping all the 3's under it, it groups the 3's under the next 2, like it's backwards
this is the code of the main procedure

Sub LoadToExcel(sFileName As String)
'On Error GoTo ErrorHandler

    Dim ofsFileSys As New Scripting.FileSystemObject
    Dim ofsTextStream As TextStream
    Dim sCurrentLine As String
    Dim objXLApp As New Excel.Application
    Dim objXLBook As New Excel.Workbook
    Dim objReportSheet As Excel.Worksheet
    Dim objMarketSheet As Excel.Worksheet
    Dim objGeoSheet As Excel.Worksheet
    Dim iSheetCount As Integer
    Dim currentRow As Long
    Dim currentCol As Long
    Dim arrRecord As Variant
    Dim intHierarchyDepth As Integer
    Dim intLastRow As Long
    
    Set ofsTextStream = ofsFileSys.OpenTextFile(sFileName, ForReading, False)
    Set objXLBook = objXLApp.Workbooks.Add
    With objXLApp
        iSheetCount = objXLBook.Sheets.Count
        'Add or delete sheets
        Do While iSheetCount < 3
            objXLBook.Worksheets.Add
            iSheetCount = iSheetCount + 1
        Loop
        Do While iSheetCount > 3
            objXLBook.Worksheets(1).Delete
            iSheetCount = iSheetCount - 1
        Loop
        With ofsTextStream
            Do While Not .AtEndOfStream
                sCurrentLine = .ReadLine
                arrRecord = Split(sCurrentLine, ",")
                Select Case Mid$(arrRecord(0), 2, 1)
                    Case "P"
                        'MsgBox "Market assignment level line"
                        If CInt(removeQuotes(CStr(arrRecord(1)))) > intHierarchyDepth Then
                            intHierarchyDepth = CInt(removeQuotes(CStr(arrRecord(1))))
                        End If
                        For currentCol = 1 To 10
                            objMarketSheet.Cells(currentRow, currentCol) = removeQuotes(CStr(arrRecord(currentCol)))
                        Next currentCol
                        currentCol = 1
                        currentRow = currentRow + 1
                        
                    Case "E"
                        'MsgBox "Geo assignment level line"
                        If CInt(removeQuotes(CStr(arrRecord(1)))) > intHierarchyDepth Then
                            intHierarchyDepth = CInt(removeQuotes(CStr(arrRecord(1))))
                        End If
                        objGeoSheet.Cells(currentRow, currentCol) = removeQuotes(CStr(arrRecord(1)))
                        objGeoSheet.Cells(currentRow, currentCol + 1) = removeQuotes(CStr(arrRecord(2)))
                        objGeoSheet.Cells(currentRow, currentCol + 2) = removeQuotes(CStr(arrRecord(3)))
                        currentRow = currentRow + 1
                        
                    Case "N"
                        'MsgBox "Geo line description"
                        objGeoSheet.Cells(currentRow, currentCol) = removeQuotes(CStr(arrRecord(1)))
                        objGeoSheet.Cells(currentRow, currentCol + 1) = removeQuotes(CStr(arrRecord(2)))
                        currentRow = currentRow + 1
                        
                    Case "D"
                        'MsgBox "Report information"
                        objReportSheet.Cells(currentRow, currentCol) = removeQuotes(CStr(arrRecord(1)))
                        currentRow = currentRow + 1
                        
                    Case "H"
                        'MsgBox "Market line description"
                        objMarketSheet.Cells(currentRow, currentCol) = removeQuotes(CStr(arrRecord(1)))
                        objMarketSheet.Cells(currentRow, currentCol + 2) = removeQuotes(CStr(arrRecord(3)))
                        currentRow = currentRow + 1
                        
                    Case "C"
                        'MsgBox "Client Header"
                        objXLBook.ActiveSheet.Cells(currentRow, currentCol) = removeQuotes(CStr(arrRecord(2)))
                        currentRow = currentRow + 1
                        
                    Case "O"
                        'MsgBox "First line" OK to create report worksheet
                        Set objReportSheet = objXLBook.Sheets(1)
                        objReportSheet.Activate
                        objReportSheet.Name = "Report Details"
                        currentRow = 1
                        currentCol = 1
                        
                    Case "M"
                        'MsgBox "Market structure sheet marker"
                        intHierarchyDepth = 2
                        Set objMarketSheet = objXLBook.Sheets(2)
                        objMarketSheet.Activate
                        objMarketSheet.Name = "Market Details"
                        currentRow = 3
                        objMarketSheet.Cells(currentRow, 1) = "Level"
                        objMarketSheet.Cells(currentRow, 2) = "NPC"
                        objMarketSheet.Cells(currentRow, 3) = "DESCRIPTION"
                        objMarketSheet.Cells(currentRow, 4) = "TAG CODE"
                        objMarketSheet.Cells(currentRow, 5) = "PFC"
                        objMarketSheet.Cells(currentRow, 6) = "ATC"
                        objMarketSheet.Cells(currentRow, 7) = "OTC"
                        objMarketSheet.Cells(currentRow, 8) = "3LT"
                        objMarketSheet.Cells(currentRow, 9) = "Molecule"
                        objMarketSheet.Cells(currentRow, 10) = "OOT"
                        objMarketSheet.Range("a1", "j3").Font.Bold = True
                        currentRow = 1
                        
                    Case "G"
                        doOutline intHierarchyDepth, currentRow - 1, objMarketSheet, objXLApp
                        'MsgBox "Geo structure sheet marker"
                        intHierarchyDepth = 2
                        Set objGeoSheet = objXLBook.Sheets(3)
                        objGeoSheet.Activate
                        objGeoSheet.Name = "Geo Details"
                        currentRow = 3
                        objGeoSheet.Cells(currentRow, 1) = "Level"
                        objGeoSheet.Cells(currentRow, 2) = "Description"
                        objGeoSheet.Cells(currentRow, 3) = "Tag code"
                        objGeoSheet.Range("a1", "j3").Font.Bold = True
                        currentRow = 1
                    Case Else
                        'MsgBox "Unknown"
                End Select
            Loop
        End With

        doOutline intHierarchyDepth, currentRow - 1, objGeoSheet, objXLApp
        objXLBook.SaveAs Application.CurrentProject.Path & "\output\" & FilePart(sFileName) & ".xls"
    End With
ExitHere:
    
    objXLApp.Quit
    Set ofsFileSys = Nothing
    Set ofsTextStream = Nothing
    Set objReportSheet = Nothing
    Set objMarketSheet = Nothing
    Set objGeoSheet = Nothing
    Set objXLBook = Nothing
    Set objXLApp = Nothing
    Exit Sub
ErrorHandler:
    MsgBox "Error: " & Err.Number & Err.Description
    GoTo ExitHere
End Sub

 

[p27br]

Aaaaaaaah I just got it, the problem was an option in excel for the grouping command :
In Group and Outline > Settings > Summary rows below detail, I unchecked that, and it works

thanks anyway for your help !

 

[GlennUK]

OK, glad you got it done.

Cheers, Glenn.

Did you hear about the literalist show-jumper? He broke his nose jumping against the clock.