Question

enter image description here

就像输入部分所示，我有一些项目的资源加载。每个项目都有多行。每周的资源加载是一列。

我想输出其季度资源负荷（列）的项目列表（每个项目都必须在一行中）。

请参考图片以获得更好的理解。

我尝试过但无法正常工作的东西：

数据透视表：

数据透视表可以帮助快速解决问题，但是由于我有基于输出的计算，因此数据透视表不够稳定，无法嵌入到fomulas中进行计算

SUMIF（Excel公式或VBA）

我在输入表中有3000多个行数据，其中包含100多个项目。 Sumif将为每个程序遍历那3000行（每列为30万行）。它有效，但是效率很低。

请让我知道问题

Answer 1

这是我为完成您需要的工作而编写的一些代码。它将在rngColToSearch范围内查找，该范围应该只是保存您的Program＃名称的数据列。 rngDataContents范围用于指定求和数字的位置。 rngOutput是您要开始写入输出的单元格。

然后它将查找并分组包含唯一程序编号的行。然后，将根据Program＃汇总每个季度（第1周到第13周，第14周到第26周，等等）的数据。

最后，它将输出从指定区域开始的数据。

代码如下（放入模块中）：

    Option Explicit

    Private Type udtMatches
        Name As String
        RowNums() As Integer
        Quarters() As Double  '0 to 3
    End Type

    Private uItems() As udtMatches

    Sub RunIT()
        mySumIF Range("A5:A27"), Range("B5:N27"), Range("G30")
    End Sub

    Public Sub mySumIF(rngColToSearch As Range, rngDataContents As Range, rngOutput As Range)
        Dim intI As Integer
        Dim intJ As Integer
        Dim intK As Integer
        Dim intL As Integer
        Dim strColValues() As String
        Dim intInMaxCol As Integer
        Dim intStartRow As Integer
        Dim intRows As Integer
        Dim strTemp As String
        Dim strCheck As String
        Dim blnFoundRow As Boolean
        Dim blnFoundName As Boolean
        Dim dblSumCols As Double
        Dim intRow As Integer
        Dim intCol As Integer

        Dim intNameCnt As Integer
        Dim intRowCnt() As Integer

        intRows = rngColToSearch.Rows.Count


        If intRows <> rngDataContents.Rows.Count Then
            MsgBox "Error: You need to select the Searching Column and the Data Contents such that" & vbCrLf & _
                   "  they have the same row count.", vbOKOnly + vbExclamation, "Bad Selection"
        Else
            'Dimension the UDT's
            ReDim uItems(0 To (intRows - 1))
            ReDim intRowCnt(0 To (intRows - 1))
            For intI = 0 To (intRows - 1)
                ReDim uItems(intI).RowNums(0 To (intRows - 1))
            Next intI

            intNameCnt = 0
            'We are good, continue
            For intI = 1 To intRows
                strTemp = LCase(Trim(rngColToSearch.Cells(intI, 1).Value))
                If intI = 1 Then
                    uItems(intNameCnt).Name = Trim(rngColToSearch.Cells(intI, 1).Value)
                    uItems(intNameCnt).RowNums(intRowCnt(intNameCnt)) = intI

                    intRowCnt(intNameCnt) = intRowCnt(intNameCnt) + 1
                    intNameCnt = intNameCnt + 1
                Else
                    blnFoundName = False
                    For intJ = 0 To (intNameCnt - 1)
                        strCheck = LCase(Trim(uItems(intJ).Name))
                        If strCheck = strTemp Then
                            blnFoundName = True
                            'Name is found, now search for Rownumber
                            blnFoundRow = False
                            For intK = 0 To (intRowCnt(intJ) - 1)
                                If uItems(intJ).RowNums(intK) = intI Then
                                    blnFoundRow = True
                                    Exit For
                                End If
                            Next intK
                            If Not blnFoundRow Then
                                'Add it to the list
                                uItems(intJ).RowNums(intRowCnt(intJ)) = intI

                                intRowCnt(intJ) = intRowCnt(intJ) + 1
                            End If
                        End If

                        If blnFoundRow Then Exit For
                    Next intJ

                    If Not blnFoundName Then
                        'Add it to the list
                        uItems(intNameCnt).Name = rngColToSearch.Cells(intI, 1).Value
                        uItems(intNameCnt).RowNums(intRowCnt(intNameCnt)) = intI

                        intRowCnt(intNameCnt) = intRowCnt(intNameCnt) + 1
                        intNameCnt = intNameCnt + 1
                    End If
                End If
            Next intI

            ReDim Preserve uItems(0 To (intNameCnt - 1))
            'Now, redim the udt's
            For intI = 0 To (intNameCnt - 1)
                ReDim Preserve uItems(intI).RowNums(0 To intRowCnt(intI) - 1)
                ReDim Preserve uItems(intI).Quarters(0 To 3)
            Next intI


            'Now, for each 13 weeks we need to add the columns 
            'intI = Quarters
            For intI = 0 To (intNameCnt - 1)

                For intK = 0 To 3
                'intJ = Weeks of Quarters
                    dblSumCols = 0
                    For intJ = 0 To (intRowCnt(intI) - 1)
                        For intL = 1 To 13
                            With rngDataContents
                                dblSumCols = dblSumCols + 
                                             CDbl(.Cells(uItems(intI).RowNums(intJ),
                                                   (intK * 13 + intL)).Value)
                            End With
                        Next intL
                    Next intJ
                    uItems(intI).Quarters(intK) = dblSumCols
                Next intK
            Next intI


            'Set up the Column and Row Labels
            intRow = 2
            intCol = 1
            For intI = 0 To (intNameCnt - 1)
                rngOutput.Cells(intRow + intI, intCol).Value = uItems(intI).Name
            Next intI
            intRow = 1
            intCol = 2
            For intI = 0 To 3
                rngOutput.Cells(intRow, intI + intCol).Value = "Q" & (intI + 1)
            Next intI


            'And finally print out the data.
            intRow = 2
            For intI = 0 To (intNameCnt - 1)
                For intJ = 0 To 3
                    rngOutput.Cells(intRow + intI, intJ + intCol).Value = 
                        uItems(intI).Quarters(intJ)
                Next intJ
            Next intI

        End If

    End Sub

汇总多个行和列的值

1 个答案: