vba制作汇总表

Posted 2023-03-31

【中文标题】vba制作汇总表

【英文标题】：Vba making summary table

【发布时间】：2020-12-22 10:35:57

【问题描述】：

我想讨论一个关于我的 VBA 代码的问题。我正在尝试根据 dpmo 列检索每个班次的前 5 名工人，如数据所示：

并将它们汇总成一个汇总表：

.

我遇到的问题是，只有当每个组有 5 个或超过 5 个值时，我的汇总表才能正确汇总值，否则它会获取下一组值并将它们插入到前一组中。我希望以这样的方式组织表格，即如果一个组的值少于 5 个，则该组的剩余行应该用“-”填充（例如，如果该组在数据框中只有两个值，那么该组的其他三个值组应该是“-”）。这是我的代码。

Sub tgr()
    Dim wsData As Worksheet
    Dim wsDest As Worksheet
    Dim rngData As Range
    Dim rngFound As Range
    Dim rngUnqGroups As Range
    Dim GroupCell As Range
    Dim lCalc As XlCalculation
    Dim aResults() As Variant
    Dim aOriginal As Variant
    Dim lNumTopEntries As Long
    Dim I As Long, J As Long, k As Long

    
    lNumTopEntries = 5

    Set wsData = ThisWorkbook.Sheets("Overview")    
    'Set wsDest = ActiveWorkbook.Sheets("Data")    

    Set rngData = wsData.Range("A1", wsData.Cells(Rows.Count, "F").End(xlUp))
    aOriginal = rngData.Value   'Store original values so you can set them back later'

    'With Application
     '   lCalc = .Calculation
      '  .Calculation = xlCalculationManual
       ' .EnableEvents = False
        '.ScreenUpdating = False
    'End With


    On Error GoTo CleanExit

    'With rngData
     '   .sort .Resize(, 6).Offset(, 0), xlAscending, .Resize(, 6).Offset(, 0), , xlAscending, Header:=xlYes
    'End With

    With rngData.Resize(, 1).Offset(, 0)
        .AdvancedFilter xlFilterInPlace, , , True
        Set rngUnqGroups = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
        .Parent.ShowAllData 'Remove the filter

        ReDim aResults(1 To rngUnqGroups.Cells.Count * lNumTopEntries, 1 To 7)
        I = 0

        For Each GroupCell In rngUnqGroups
            Set rngFound = .Find(GroupCell.Value, .Cells(.Cells.Count))
            k = 0
            If Not rngFound Is Nothing Then
                For J = I + 1 To I + lNumTopEntries
                    If rngFound.Offset(J - I - 1).Value = GroupCell.Value Then
                        k = k + 1
                        'aResults(j, 1) = rngFound.Offset(j - i - 1, -1).Value
                        aResults(J, 2) = rngFound.Offset(J - I - 1).Value
                        aResults(J, 3) = rngFound.Offset(J - I - 1, 1).Value
                        aResults(J, 4) = rngFound.Offset(J - I - 1, 2).Value
                        aResults(J, 5) = rngFound.Offset(J - I - 1, 3).Value
                        aResults(J, 6) = rngFound.Offset(J - I - 1, 4).Value
                        aResults(J, 7) = rngFound.Offset(J - I - 1, 5).Value
                    End If
                Next J
                I = I + k
            End If
        Next GroupCell
    End With


    wsData.Range("G:Z").Clear
    wsData.Range("K5").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults

CleanExit:
  
    With Application
        .Calculation = lCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    If Err.Number <> 0 Then
      
        MsgBox Err.Description, , "Error: " & Err.Number
        Err.Clear
    End If

    
    rngData.Value = aOriginal
'Call summ_table
End Sub

如果有人可以在我的代码中帮助我，将不胜感激。另请注意，原因列和顶部列是在检索到顶部值之后插入的。

【参考方案1】：

移动k = k + 1。

不是这个

For J = I + 1 To I + lNumTopEntries
    If rngFound.Offset(J - I - 1).Value = GroupCell.Value Then
        k = k + 1
        'aResults(j, 1) = rngFound.Offset(j - i - 1, -1).Value
        aResults(J, 2) = rngFound.Offset(J - I - 1).Value
        aResults(J, 3) = rngFound.Offset(J - I - 1, 1).Value
        aResults(J, 4) = rngFound.Offset(J - I - 1, 2).Value
        aResults(J, 5) = rngFound.Offset(J - I - 1, 3).Value
        aResults(J, 6) = rngFound.Offset(J - I - 1, 4).Value
        aResults(J, 7) = rngFound.Offset(J - I - 1, 5).Value
    End If
Next J

使用这个：

For J = I + 1 To I + lNumTopEntries
    If rngFound.Offset(J - I - 1).Value = GroupCell.Value Then
        'aResults(j, 1) = rngFound.Offset(j - i - 1, -1).Value
        aResults(J, 2) = rngFound.Offset(J - I - 1).Value
        aResults(J, 3) = rngFound.Offset(J - I - 1, 1).Value
        aResults(J, 4) = rngFound.Offset(J - I - 1, 2).Value
        aResults(J, 5) = rngFound.Offset(J - I - 1, 3).Value
        aResults(J, 6) = rngFound.Offset(J - I - 1, 4).Value
        aResults(J, 7) = rngFound.Offset(J - I - 1, 5).Value
    End If
    k = k + 1
Next J

【讨论】：

如果答案有助于解决问题，请检查答案旁边的 ✓ 符号。

顺便说一句，我非常喜欢你设计 CleanExit 部分的方式。

非常感谢您的评论，但现在当我按照您的建议修改我的代码时，我正在跳过其他组，我也想保留它们