Сценарий Excel VBA не работает при группировании нескольких уровней

Question

У меня есть документ Excel, который запускает сценарий VBA, который я использую пользовательские формы для ввода данных. Скрипт работает отлично, кроме группировки. Есть 2 группы. Первый на имя клиента, который отлично работает. Второе - это Имя Усилия, которого нет. Он группирует усилия, но при группировке все равно отображает последний ряд. Разработчик, которого я нанял для написания сценария, сказал, что эта ошибка, по-видимому, является ошибкой в ​​Excel или по какой-то причине, когда две группы имеют одну и ту же последнюю строку.

У кого-нибудь есть решение?

Изображения показывают скрипт макроса и группировку Изображение marcos Изображение группировки

Ниже приведен скрипт VBA, который был написан для создания усилия с помощью Форма пользователя.

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

Answer 1

Схема (группа) в Excel требует строки сводки, которая в зависимости от настроек, установленных на вашем компьютере, должна располагаться ниже (по умолчанию) или над каждым уровнем схемы.

Ваша ситуация

Что происходит в вашей электронной таблице, так это то, что в настоящее время у вас есть настройки по умолчанию, т.е. итоговая строка должна быть ниже текущего уровня структуры. И вы группируете строки 9,10 и 13.

Я предполагаю, что разработчик попытался сгруппировать effort 1 и effort 2, и это не сработало, потому что сгруппировать effort 2 без выход из дополнительной строки будет выглядеть следующим образом:

Примечание. См. 4 точки справа от строк с 13 по 16

---

Решение Excel

В этом случае вам необходимо переключить настройки, чтобы итоговые строки находились выше детализации

Как настроить параметры

Настройки схемы:

Текущая конфигурация:

Настроенная конфигурация

Это позволило бы получить в итоговой строке выше детали, подобные этой:

А при свертывании:

Решение VBA

Теперь о коде VBA, который у вас есть, хотя он, конечно, может быть улучшенным, я понимаю, что выполняет ваши требования.

Предлагаю специально проверить эти два блока:

Блок № 1:

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

Блок № 2

''ungroup and group old project data

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

Я бы предложил Разработчик прочитает эту статью о том, как и почему следует избегать выбора в Excel VBA .

---

Пожалуйста, дайте мне знать, если решение работает, и не забудьте пометить ответ (поставьте галочку отметьте слева), если это так.