Sub Podarki_NG()
Dim wsShablon As Worksheet, wsAdd As Worksheet, wsSheet As Worksheet
Dim arrData()
Dim dicWs As Object, dicCity As Object, dicAddress As Object, dicKont As Object
Dim x As Integer, i As Integer, rw As Integer, nub As Integer
Set dicWs = CreateObject("Scripting.Dictionary")
Set dicCity = CreateObject("Scripting.Dictionary")
Set dicAddress = CreateObject("Scripting.Dictionary")
Set dicKont = CreateObject("Scripting.Dictionary")
Set wsShablon = ThisWorkbook.Worksheets("ШАБЛОН")
Set wsSheet = ThisWorkbook.Worksheets("Лист рассылки")
nub = 2
Application.ScreenUpdating = False
With wsSheet
    If .Range("A2") <> "" Then .Range("A2", .Range("E" & .Range("A2").End(xlDown).Row)).ClearContents
End With
If ThisWorkbook.Worksheets.Count > 4 Then
    Application.DisplayAlerts = False
    For x = ThisWorkbook.Worksheets.Count To 5 Step -1
        ThisWorkbook.Worksheets(x).Delete
    Next x
    Application.DisplayAlerts = True
End If
arrData = ThisWorkbook.Sheets("Общий список").Range("A1").CurrentRegion.Value
For x = 2 To UBound(arrData, 1)
    If Not dicWs.Exists(arrData(x, 10)) Then dicWs.Add arrData(x, 10), arrData(x, 10)
Next x
For x = 0 To dicWs.Count - 1
    For i = 2 To UBound(arrData, 1)
        If arrData(i, 10) = dicWs.Keys()(x) And Not dicCity.Exists(arrData(i, 8)) Then dicCity.Add arrData(i, 8), arrData(i, 8)
    Next i
    For i = 0 To dicCity.Count - 1
        For r = 2 To UBound(arrData, 1)
            If arrData(r, 10) = dicWs.Keys()(x) And arrData(r, 8) = dicCity.Keys()(i) Then
                If Not dicAddress.Exists(arrData(r, 9)) Then
                    dicAddress.Add arrData(r, 9), arrData(r, 9)
                    If Not dicKont.Exists(arrData(r, 11)) Then dicKont.Add arrData(r, 11), arrData(r, 11)
                End If
            End If
        Next r
        For r = 0 To dicAddress.Count - 1
            Set wsAdd = ThisWorkbook.Worksheets.Add(, ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            With wsAdd
                .Name = dicWs.Keys()(x) & "-" & nub - 1
                .Tab.Color = vbRed
                wsShablon.Cells.Copy .Range("A1")
                .Range("B4") = dicCity.Keys()(i)
                .Range("B5") = dicAddress.Keys()(r)
                .Range("B6") = dicWs.Keys()(x)
                .Range("B7") = dicKont.Keys()(r)
                rw = 10
                For s = 2 To UBound(arrData, 1)
                    If arrData(s, 8) = dicCity.Keys()(i) And arrData(s, 9) = dicAddress.Keys()(r) And arrData(s, 10) = dicWs.Keys()(x) Then
                        .Range("E" & rw) = arrData(s, 2)
                        .Range("F" & rw) = arrData(s, 7)
                        rw = rw + 1
                    End If
                Next s
                .Range("B" & rw, .Range("B" & rw).End(xlDown)).EntireRow.Delete
            End With
            With wsSheet
                .Range("A" & nub) = nub - 1
                .Range("B" & nub) = dicCity.Keys()(i)
                .Range("C" & nub) = dicAddress.Keys()(r)
                .Range("D" & nub) = wsAdd.Range("C" & rw + 1)
                .Range("E" & nub) = wsAdd.Name
                nub = nub + 1
            End With
        Next r
        dicAddress.RemoveAll
        dicKont.RemoveAll
    Next i
    dicCity.RemoveAll
Next x
Set dicWs = Nothing
Set dicCity = Nothing
Set dicAddress = Nothing
Set dicKont = Nothing
Application.ScreenUpdating = True
End Sub