Sub CitySplit()
Dim iCl As Range
Dim cellCity As Range
Dim sPrd$
Dim iRng As Range
Dim arr()
Dim iAdr$
Dim lRow&, lClm&, I&, J&
Dim dic As Object
Dim dicSheets As Object
Dim iKey, iTmp, dArr
Dim iSh As Worksheet

On Error Resume Next

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set dic = CreateObject("Scripting.Dictionary")
ReDim dArr(1 To 2, 1 To 1)
With Worksheets("Основной")
  lRow = .Cells(.Rows.Count, "C").End(xlUp).Row
  With .Range("C1:C" & lRow)
    Set iCl = .Find("Продукт", LookIn:=xlValues)
    If Not iCl Is Nothing Then
      iAdr = iCl.Address
      Do
        'наименование продукта
        sPrd = iCl.Offset(1, 1).Value
        'верхняя левая ячейка диапазона с данными по городам
        Set cellCity = iCl.Offset(3, 3)
        
        With Worksheets("Основной")
          lClm = .Cells(cellCity.Row, .Columns.Count).End(xlToLeft).Column - 5
          Set iRng = cellCity.Resize(iCl.CurrentRegion.Rows.Count - 3, lClm)
        End With
        arr = iRng.Value
        ReDim iTmp(1 To 2, 1 To 1)
        For J = LBound(arr, 2) To UBound(arr, 2)
          iKey = arr(1, J)
          iTmp(1, 1) = sPrd
          For I = UBound(arr, 1) To LBound(arr, 1) + 1 Step -1
            If Not IsEmpty(arr(I, J)) Then
              iTmp(2, 1) = arr(I, J)
              Exit For
            End If
          Next
          If Not dic.Exists(iKey) Then
            dic.Add iKey, iTmp
          Else
            dArr = dic(iKey)
            ReDim Preserve dArr(1 To 2, 1 To UBound(dArr, 2) + 1)
            dArr(1, UBound(dArr, 2)) = iTmp(1, 1)
            dArr(2, UBound(dArr, 2)) = iTmp(2, 1)
            dic(iKey) = dArr
          End If
        Next
        Set iCl = .FindNext(iCl)
      Loop While iCl.Address <> iAdr
    End If
  End With
End With
Set dicSheets = CreateObject("Scripting.Dictionary")
For Each iSh In ThisWorkbook.Worksheets
  iTmp = dicSheets(iSh.Name)
Next
For Each iKey In dic.Keys
  If dicSheets.Exists(iKey) Then ThisWorkbook.Worksheets(iKey).Delete
  Set iSh = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
  iSh.Name = iKey
  dArr = dic(iKey)
  iSh.Range("A1").Resize(UBound(dArr, 2), 2) = Application.Transpose(dArr)
  iSh.Cells.EntireColumn.AutoFit
Next
Worksheets("Основной").Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub