Option Explicit
Sub abc_xyz()
Const datasht = "List1"
Const rsltcell = "G1" 'Tut budet resul'tat raboty makrosa
Dim i&, idx&, j&, k&, dict, itm, ky, tbl
'--------------------------------------------------------------------------
With ThisWorkbook.Sheets(datasht)
tbl = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
idx = UBound(tbl, 1)
For i = 1 To idx
If Trim(tbl(i, 3)) <> "" Then tbl(i, 3) = 1 Else tbl(i, 3) = 0
If Trim(tbl(i, 4)) <> "" Then tbl(i, 4) = 1 Else tbl(i, 4) = 0
If Trim(tbl(i, 5)) <> "" Then tbl(i, 5) = 1 Else tbl(i, 5) = 0
Next
'--------------------------------------------------------------------------
For i = 1 To idx - 1
For j = i + 1 To idx
If tbl(i, 2) & ";" & tbl(i, 1) > tbl(j, 2) & ";" & tbl(j, 1) Then
For k = 1 To 5
ky = tbl(j, k)
tbl(j, k) = tbl(i, k)
tbl(i, k) = ky
Next
End If
Next
Next
'--------------------------------------------------------------------------
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To idx
ky = tbl(i, 2) & ";" & tbl(i, 1)
If Not dict.Exists(ky) Then dict(ky) = 1
Next
k = dict.Count: dict.RemoveAll: Set dict = Nothing
'--------------------------------------------------------------------------
dict = Empty: ReDim dict(1 To k, 1 To 4): k = 1
dict(1, 1) = tbl(1, 2) & ";" & tbl(1, 1)
For j = 2 To 4
dict(1, j) = tbl(1, j + 1)
Next
For i = 2 To idx
ky = tbl(i - 1, 2) & ";" & tbl(i - 1, 1)
itm = tbl(i, 2) & ";" & tbl(i, 1)
If itm <> ky Then
k = k + 1
dict(k, 1) = itm
For j = 2 To 4
dict(k, j) = tbl(i, j + 1)
Next
Else
For j = 2 To 4
If dict(k, j) = 0 And tbl(i, j + 1) = 1 Then dict(k, j) = 1
Next
End If
Next
'--------------------------------------------------------------------------
tbl = Empty: j = 0: ReDim tbl(1 To k, 1 To 4)
For i = 1 To k Step 3
j = j + 1
tbl(j, 1) = Split(dict(i, 1), ";", -1, 1)(0) 'Gorod
tbl(j, 2) = dict(i, 2) + dict(i, 3) + dict(i, 4) 'UROiK1
tbl(j, 3) = dict(i + 1, 2) + dict(i + 1, 3) + dict(i + 1, 4) 'UROiK2
tbl(j, 4) = dict(i + 2, 2) + dict(i + 2, 3) + dict(i + 2, 4) 'UROiK3
Next
dict = Empty
'--------------------------------------------------------------------------
With ThisWorkbook.Sheets(datasht)
With .Range(rsltcell)
If .MergeCells Then .MergeArea.UnMerge
.Value = "Kolichestvo"
.Offset(1, 0).Resize(1, 4).Value = Array("Gorod", "UROiK1", "UROiK2", "UROiK3")
.Offset(2, 0).Resize(j, 4).Value = tbl: tbl = Empty
.Offset(j + 2, 0).Value = "Itogo"
.Offset(j + 2, 1).Resize(1, 3).FormulaR1C1 = "=SUM(R[-" & j & "]C:R[-1]C)"
.Resize(1, 4).Merge (True)
End With
End With
End Sub
|