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

Excel VBA script not working when grouping multiple levels

Answers (1)

Your situation

The Excel solution

How to adjust the settings

The VBA solution

Related Questions