在VBA中动态分组

Question

我在查询其他帮助来更改报告。我对VBA相当陌生，并且在Excel 2010中编写了下面的代码。快速背景 - 数据正在用SQL收集，然后由专有软件生成以实现卓越。我期待通过突出显示外部边界来对动态数据集进行分组。数据集总是从B4开始，我已经在下面定义了。基本上，我创建了这个脚本，在B列中有一个“GroupSummary”值的时候突出显示一个分组。分组结束于最后一行，任何时候有一个值“2”，后面是一个值“0”。在下面的例子中，分组将在3行

结束例如：

ROW 1 "Group Summary" , "A" , "0" 
ROW 2 "Summary" ,  "A" , "2" 
ROW 3 "Summary" ,  "A" , "2" 
ROW 4 "Summary" ,  "B" , "0" 

我现在想更进一步借此，并强调只有分组当上述条件得到满足，所有的最后一列中的值是相同的。见下面的例子。分组应在第3行

ROW 1 "Group Summary" , "A" , "0" 
ROW 2 "Summary" ,  "A" , "2" 
ROW 3 "Summary" ,  "A" , "2" 
ROW 4 "Summary" ,  "B" , "2" 
ROW 5 "Summary" ,  "B" , "0" 

这里就结束了，是我已经写的代码：

Dim LastCol As Integer 
Dim Z As Integer, StartRow As Integer, EndRow As Integer 
LastCol = Range("B4").End(xlToRight).Column 
Z = 5 
Do 

    If Cells(Z, LastCol) = 0 And StartRow <> 0 Then 
     EndRow = Z - 1 
     Range(Cells(StartRow, 2), Cells(EndRow, LastCol - 2)).Select 
     With Selection 
       .Borders(xlEdgeLeft).Weight = xlMedium 
       .Borders(xlEdgeLeft).ColorIndex = 1 
       .Borders(xlEdgeRight).Weight = xlMedium 
       .Borders(xlEdgeRight).ColorIndex = 1 
       .Borders(xlEdgeTop).Weight = xlMedium 
       .Borders(xlEdgeTop).ColorIndex = 1 
       .Borders(xlEdgeBottom).Weight = xlMedium 
       .Borders(xlEdgeBottom).ColorIndex = 1 
     End With 
     StartRow = 0 
    End If 

    If Cells(Z, 2) = "GroupSummary" Then 
     StartRow = Z 

    End If 

    Z = Z + 1 

    Loop Until Cells(Z, 2) = "" And Cells(Z - 1, 2) = "" 

Answer 1

下面的代码产生以下输出 - 为您调整无疑（阴影组是您的数据的例子）：

代码：保持你的基本方法

Sub grps() 
Dim FirstCol As Long, LastCol As Long 
Dim grpRows As Long, grpHere As Long 
Dim Z As Long, StartRow As Long, EndRow As Long, gsRow As Long 
Dim grpChar As String 

FirstCol = 2 'col B 
StartRow = 4 
EndRow = Cells(Rows.Count, FirstCol).End(xlUp).Row 
LastCol = Cells(StartRow, Columns.Count).End(xlToLeft).Column 

    For Z = StartRow To EndRow 

     If Cells(Z, FirstCol) = "Group Summary" Then 
      gsRow = Z 
      grpRows = 1 

      With Cells(gsRow, FirstCol) 
       grpChar = .Offset(0, 1) 
       grpHere = gsRow 

       Do Until .Offset(grpRows, 2) = 0 
        If .Offset(grpRows, 1) = grpChar Then 
         grpHere = gsRow + grpRows 
         grpRows = grpRows + 1 
        Else 
         Exit Do 
        End If 
       Loop 

       If grpRows > 1 Then 
        Range(Cells(gsRow, FirstCol), Cells(grpHere, FirstCol + 1)).Select 
        With Selection 
         .Borders(xlEdgeLeft).Weight = xlMedium 
         .Borders(xlEdgeLeft).ColorIndex = 1 
         .Borders(xlEdgeRight).Weight = xlMedium 
         .Borders(xlEdgeRight).ColorIndex = 1 
         .Borders(xlEdgeTop).Weight = xlMedium 
         .Borders(xlEdgeTop).ColorIndex = 1 
         .Borders(xlEdgeBottom).Weight = xlMedium 
         .Borders(xlEdgeBottom).ColorIndex = 1 
        End With 

       End If 
      End With 
     End If 
    Next Z 

End Sub