Вот код, над которым я работал, чтобы сделать то, что вам нужно. Он будет выглядеть в диапазоне rngColToSearch, который должен быть просто столбцом данных, в котором хранятся ваши имена программ. Диапазон rngDataContents используется, чтобы указать, где у вас есть числа для суммирования. rngOutput - это ячейка, в которую вы хотите записать вывод.
Затем он найдет и сгруппирует строки, которые содержат уникальные номера программ. Затем данные за каждый квартал (от недели 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