Excel VBA script not working when grouping multiple levels

Question

I have an excel document that runs a VBA script that I use user forms to input data. The script works fine, except for the grouping. There are 2 groups. The first is at the Customer Name, which works fine. The second is at the Effort Name, which does not. It groups the effort, but when grouped it still displays the last row. The developer I hired to write the script said that this error appears to be a bug in Excel or for some reason by design when two groups have the same last row.

Does anyone have a solution?

Images show the macros script and grouping Image of marcos Image of grouping

Below is the VBA script that was written for creating the effort via user form.

Private Sub ButtonAddEffort_Click()
Dim c As Object
Dim sht As Worksheet
Dim foundrow As Long
Dim blassign As Boolean
Dim x As Long
Dim rowstart As Long
Dim rowend As Long
Dim i As Long
Dim rowstarteffort As Long

If IsNull(Me.txtProjectNumberLocate) Or Me.txtProjectNumberLocate = "" Then
    MsgBox "Please enter a project number."
    Me.txtProjectNumberLocate.SetFocus
    Exit Sub
End If

If IsNull(Me.txtEffortName) Or Me.txtEffortName = "" Then
    MsgBox "Please enter an effort name."
    Me.txtEffortName.SetFocus
    Exit Sub
End If

If Not IsNull(Me.txtStartDate) And Me.txtStartDate <> "" Then
    If Not IsDate(Me.txtStartDate) Then
        MsgBox "Please enter a valid start date in 'mm/dd/yyyy' format."
        Me.txtStartDate.SetFocus
        Exit Sub
    End If
End If
If Not IsNull(Me.txtFinishDate) And Me.txtFinishDate <> "" Then
    If Not IsDate(Me.txtFinishDate) Then
        MsgBox "Please enter a valid finish date in 'mm/dd/yyyy' format."
        Me.txtFinishDate.SetFocus
        Exit Sub
    End If
End If


Set sht = Sheets("Sheet1")

Set c = sht.Range("F:F").Find(what:=Me.txtProjectNumberLocate, after:=sht.Cells(1, 6), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious, MatchCase:=False)
If Not c Is Nothing Then
    foundrow = c.Row
    rowstart = foundrow
    rowstarteffort = foundrow
Else
    foundrow = 0
End If

If foundrow = 0 Then
    MsgBox "Could not find project # " & Me.txtProjectNumberLocate
    Exit Sub
End If
''any efforts exist1
Set c = sht.Range("A:A").Find(what:="*", after:=sht.Cells(foundrow, 1), LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If Not c Is Nothing Then
    foundrownext = c.Row
Else
    foundrownext = 0
End If
If foundrownext > foundrow Then
    foundrow = foundrownext - 1
End If


'check work order format
For x = 1 To 8
    If Not IsNull(Me("txtworkorder" & x)) And Me("Txtworkorder" & x) <> "" Then
        If Me("CheckBox" & x) = True Then
            If Len(Me("txtWorkOrder" & x)) <> 8 Then
                MsgBox "Work order numbers must be in 'xxxx-xxx' format."
                Me("txtWorkOrder" & x).SetFocus
                Exit Sub
            End If
            If InStr(1, Me("txtWorkOrder" & x), "-") = 0 Then
                MsgBox "Work order numbers must be in 'xxxx-xxx' format."
                Me("txtWorkOrder" & x).SetFocus
                Exit Sub
            End If
            If Mid(Me("txtworkorder" & x), 5, 1) <> "-" Then
                MsgBox "Work order numbers must be in 'xxxx-xxx' format."
                Me("txtWorkOrder" & x).SetFocus
                Exit Sub
            End If
            If InStr(1, Left(Me("txtWorkOrder" & x), 4), "-") <> 0 Then
                MsgBox "Work order numbers must be in 'xxxx-xxx' format."
                Me("txtWorkOrder" & x).SetFocus
                Exit Sub
            End If
            If InStr(1, Right(Me("txtWorkOrder" & x), 3), "-") <> 0 Then
                MsgBox "Work order numbers must be in 'xxxx-xxx' format."
                Me("txtWorkOrder" & x).SetFocus
                Exit Sub
            End If
        End If
    End If
Next x
i = 0

If foundrownext > 1 Then
    sht.Rows(rowstart + 1 & ":" & foundrownext - 1).Select
    On Error Resume Next
    Selection.Rows.Ungroup
    On Error GoTo 0
End If
blassign = False
For x = 8 To 1 Step -1
    If Me("CheckBox" & x) = True Then
       blassign = True
    End If
Next x
If blassign = False Then
    sht.Range(foundrow + 1 & ":" & foundrow + 1).EntireRow.Insert shift:=xlDown
    sht.Range("B" & foundrow + 1) = Me.txtEffortName
    sht.Range("B" & foundrow + 1).Font.Color = 13998939
    sht.Range("B" & foundrow + 1).Font.Underline = True
    sht.Range("I" & foundrow + 1) = Me.txtStartDate
    sht.Range("J" & foundrow + 1) = Me.txtFinishDate
    i = 1
Else
    sht.Range(foundrow + 1 & ":" & foundrow + 1).EntireRow.Insert shift:=xlDown
    sht.Range("B" & foundrow + 1) = Me.txtEffortName
    sht.Range("B" & foundrow + 1).Font.Color = 13998939
    sht.Range("B" & foundrow + 1).Font.Underline = True
    sht.Range("I" & foundrow + 1) = Me.txtStartDate
    sht.Range("J" & foundrow + 1) = Me.txtFinishDate
    For x = 8 To 1 Step -1
        If Me("CheckBox" & x) = True Then
            sht.Range(foundrow + 2 & ":" & foundrow + 2).EntireRow.Insert shift:=xlDown
            sht.Range("F" & foundrow + 2) = Me("txtWorkOrder" & x)
            sht.Range("G" & foundrow + 2) = Me("cmbAssign" & x)
            i = i + 1
        End If
    Next x
End If

''group new efforts
If foundrownext <= 1 Then
    foundrownext = rowstart + 1
End If
sht.Rows(foundrow + 2 & ":" & foundrownext + i).Select
Selection.Rows.Group


''ungroup and group old project data

rowend = foundrownext + i - 1
sht.Rows(rowstart + 1 & ":" & rowend).Select
Selection.Rows.Group


''
MsgBox "Done!"
End Sub

Private Sub ButtonClose_Click()
Unload Me
End Sub



Private Sub ComboBox1_Change()

End Sub

Private Sub ComboBox2_Change()

End Sub

Private Sub ComboBox3_Change()

End Sub

Private Sub ComboBox4_Change()

End Sub

Private Sub TextBox9_Change()

End Sub

Private Sub UserForm_Click()

End Sub

Can you manually achieve the grouping you want? If not, then you won't be able to do it with VBA either. I'm guessing from your screenshot that you won't be able to do this. — BigBen, Jan 10 '20 at 18:56

score 1 · Answer 1 · edited Jun 20 '20 at 09:12

Outline (group) in Excel requires a summary row, that depending on the settings you have in your computer, should be placed below (default) or above each outline level.

Your situation

What's happening in your spreadsheet is that you currently have the default settings, i.e. summary row should be below the current outline level. And you're grouping the rows 9,10 and 13.

My guess here is that the developer tried to group effort 1 and effort 2 and it didn't work, because to group effort 2 without leaving an additional row would just look like this:

Note: See the 4 dots on the right of rows 13 to 16

The Excel solution

In this case, you need to toggle the settings so the summary rows are above the detail

How to adjust the settings

Outline settings:

Current configuration:

Adjusted configuration

This would allow to have the summary row above details like this:

And when collapsed:

The VBA solution

Now, about the VBA code you have, although it can certainly be improved, I understand it accomplishes your requirements.

I suggest to specially check these two blocks:

Block # 1:

''group new efforts
If foundrownext <= 1 Then
    foundrownext = rowstart + 1
End If
sht.Rows(foundrow + 2 & ":" & foundrownext + i).Select
Selection.Rows.Group

Block #2

''ungroup and group old project data

rowend = foundrownext + i - 1
sht.Rows(rowstart + 1 & ":" & rowend).Select
Selection.Rows.Group

I'd suggest the developer to read this article on how and why to avoid select in Excel VBA.

Please let me know if the solution works and remember to mark the answer (tick the check mark at the left) if it does.

Toggling the settings so that the summary rows are above the detail does not seem to be the solution. When I collapse the group, that the last row within the effort is still visible and should not be. What do you suggest? — Erin M, Jan 10 '20 at 21:13
Code is not grouping that last row, so it'd have to include it. but by the way it is being programmed, I think it's better to refactor it completely. Can you upload the file in google drive or onedrive with sample data? (at least including the user form and the sheet that holds the data). — Ricardo Diaz, Jan 10 '20 at 21:29
@RicardoDiaz Thanks a lot for your answer. My grouping VBA code was fine but Excel never displayed that last grouping of the second level. By chaning the Direction as in your answer it works just fine! — Sebastien, Oct 29 '20 at 18:12

Excel VBA script not working when grouping multiple levels

1 Answers1

Your situation

The Excel solution

How to adjust the settings

The VBA solution