vba制作汇总表

编程问答 2022-06-02

问题描述

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

Data

并将它们汇总成汇总表：

Table

。

我遇到的问题是，只有当每个组有 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(,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

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

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）

arraysarraysexcelexcelsummarytop-n