Sub Test()
Dim arr(), i As Long, it, arr1, y&, arr2, yes, ass, v
Application.ScreenUpdating = False
With Sheets(1)
arr = .Range("A2:F" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
With CreateObject("Scripting.Dictionary")
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 1) <> "" Then
If arr(i, 2) = "" Then arr(i, 2) = 0
it = arr(i, 1)
If arr(i, 3) = "" Then arr(i, 3) = 0
If arr(i, 4) = "" Then arr(i, 4) = 0
If arr(i, 5) = "" Then arr(i, 5) = 0
If arr(i, 6) = "" Then arr(i, 6) = 0
.Item(it) = .Item(it) & ", " & arr(i, 2) & "|" & arr(i, 3) & _
"|" & arr(i, 4) & "|" & arr(i, 5) & "|" & arr(i, 6)
End If
Next i
ReDim arr2(1 To .Count, 1 To 6)
i = 1
For Each it In .Keys
arr1 = Split(it, "")
arr2(i, 1) = arr1(0)
For Each yes In Split(Mid(.Item(it), 3), ", ")
arr2(i, 2) = arr2(i, 2) * 1 + Split(yes, "|")(0) * 1
arr2(i, 3) = arr2(i, 3) * 1 + Split(yes, "|")(1) * 1
arr2(i, 4) = arr2(i, 4) * 1 + Split(yes, "|")(2) * 1
arr2(i, 5) = arr2(i, 5) * 1 + Split(yes, "|")(3) * 1
arr2(i, 6) = arr2(i, 6) * 1 + Split(yes, "|")(4) * 1
Next
i = i + 1
Next it
End With
With Sheets(2)
.Cells.Clear
.[A1].Resize(1, 6).Value = Array("Услуги", "Всего", "Бюджет", "Внебюджет", "НИС", "НИР")
.[a2].Resize(i - 1, 6).Value = arr2
With .UsedRange
.Borders().LineStyle = xlContinuous
End With
End With
Application.ScreenUpdating = True
End Sub
Войти
Регистрация
Наверх
