时间戳

首页 > 解决方案 > 对多个级别进行分组时，Excel VBA 脚本不起作用

excel - 对多个级别进行分组时，Excel VBA 脚本不起作用

问题描述

我有一个运行 VBA 脚本的 excel 文档，我使用用户表单输入数据。该脚本工作正常，除了分组。有2组。第一个是客户名称，它工作正常。第二个是 Effort Name，它没有。它对工作进行分组，但在分组时仍显示最后一行。我聘请来编写脚本的开发人员说，这个错误似乎是 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

标签： excelvba

解决方案

Excel 中的大纲（组）需要一个摘要行，根据您计算机中的设置，应将其放置在每个大纲级别下方（默认）或上方。

你的情况

您的电子表格中发生的情况是您当前具有默认设置，即摘要行应低于当前大纲级别。您正在对第 9,10 和 13 行进行分组。

我的猜测是，开发人员试图进行分组effort 1，effort 2但没有成功，因为在effort 2不留下额外行的情况下进行分组看起来像这样：

努力 2 不分组

注：见第 13 至 16 行右侧的 4 个点

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 中选择的文章。

请让我知道解决方案是否有效，如果有效，请记住标记答案（勾选左侧的复选标记）。

推荐阅读