在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