Попробуйте пожалуйста следующий код. Он не использует Sumproducts. Он работает только в памяти с использованием массивов и сбрасывает результат сразу, в конце кода. Ниже Sub принимает параметры и может быть вызван для любого ID:
Private Sub FindOutputTable(sh1 As Worksheet, sh2 As Worksheet, ID As String)
Dim lastRow As Long, lastCol As Long, lastR2 As Long
Dim arr1 As Variant, arr2 As Variant, i As Long, j As Long
lastRow = sh1.Range("A" & Rows.count).End(xlUp).Row
lastCol = sh1.Cells(1, Columns.count).End(xlToLeft).Column
lastR2 = sh2.Range("A" & Rows.count).End(xlUp).Row
arr1 = sh1.Range(sh1.Cells(2, 1), sh1.Cells(lastRow, lastCol)).value
If lastR2 = 1 Then 'if the sheet is blank, the array will also include the headers
ReDim arr2(1 To 2, 1 To 4)
Else 'the array will contain only one row, keeping the necessary values
ReDim arr2(1 To 1, 1 To 4)
End If
arr2(IIf(lastR2 = 1, 2, 1), 1) = ID' the row where ID will be returned is chosen according to the lastR value
For i = 1 To UBound(arr1, 1)
If arr1(i, 1) = ID Then
If arr1(i, 2) < 7 Then
arr2(IIf(lastR2 = 1, 2, 1), 2) = arr2(IIf(lastR2 = 1, 2, 1), 2) + 1
If arr1(i, 3) = "Owner" Then
arr2(IIf(lastR2 = 1, 2, 1), 3) = arr2(IIf(lastR2 = 1, 2, 1), 3) + 1
ElseIf arr1(i, 3) = "Lead" Then
arr2(IIf(lastR2 = 1, 2, 1), 4) = arr2(IIf(lastR2 = 1, 2, 1), 4) + 1
End If
End If
End If
Next
If lastR2 = 1 Then 'For a blank sheet, the headers are also added
sh2.Range("A1").Resize(UBound(arr2, 1), UBound(arr2, 2)).value = arr2
sh2.Range("A1").Resize(, 4).value = Split("Report ID,Get_Days_LessThan7,PendingOwnerLT7,PendingLeadLT7", ",")
Else 'Only the collected values will be returned
sh2.Range("A" & lastR2 + 1).Resize(UBound(arr2, 1), UBound(arr2, 2)).value = arr2
End If
End Sub
Пожалуйста, будьте осторожны и используйте свои листы (sheet1 и sheet2). Для тестирования я использовал активный лист и последний лист для возврата результата ...
Чтобы проверить это, используйте следующий код:
Sub testFindOutputTable()
Dim sh1 As Worksheet, sh2 As Worksheet, ID As String
ID = "155"
Set sh1 = ActiveSheet 'you may use here your sheet1
Set sh2 = Worksheets(Worksheets.count) ' you will use here your sheet2
FindOutputTable sh1, sh2, ID
End Sub
Вы также можете выполнить итерацию, в приведенном выше тестовом сабе между всеми вашими IDs. Если вы не понимаете, как, я могу помочь вам с примером. Все Ваши IDs должны быть введены в массив и перебирать элементы массива, которые вы можете выполнить sh, запустив подпрограмму для всех ваших ID`. Код сначала заполняет заголовки столбцов, а затем только собранные значения.
Вариант, включающий итерации между существующими ID, должен выглядеть следующим образом:
Sub testFindOutputTable()
Dim sh1 As Worksheet, sh2 As Worksheet, El As Variant, arrID As Variant
arrID = Split("155,156", ",")
'ID = "155"
Set sh1 = ActiveSheet 'you may use here your sheet1
Set sh2 = Worksheets(Worksheets.count) ' you will use here your sheet2
For Each El In arrID
FindOutputTable sh1, sh2, CStr(El)
Next
End Sub
Вы можете использовать вместо «155,156» столько идентификаторов, сколько вам нужно, но через запятую. Если у вас есть где-то в диапазоне эти идентификаторы, вы можете сразу ввести их в массив, используя что-то вроде этого: arrID = range("yourRange").value