Sub Макрос1()
    For Each cell In Range("B2:B6")
      If Len(cell) = 5 Then
       cell.Offset(, 1) = cell
       cell.Offset(, 1).NumberFormat = "#-##-##"
      ElseIf Len(cell) = 10 Then
       cell.Offset(, 1) = cell
       cell.Offset(, 1).NumberFormat = "+7(###)###-##-##"
      End If
    Next
End Sub

Sub Zadacha_2()
Application.ScreenUpdating = False 'инструкция для отключения обновления экрана во время отработки кода (д/быстродействия)
Dim arrTable As Variant 'переменная variant для таблицы-массива
  arrTable = Worksheets("Решение").Range("A1:C10") 'где находится массив, обозначение его границ
  Sheets.Add After:=Sheets("Решение") 'создать новый лист после листа "Решение"
  ActiveSheet.Range("A1").Resize(UBound(arrTable), UBound(arrTable, 2)) = arrTable
  ActiveSheet.Name = "1" 'присвоить листу имя "1"
Application.ScreenUpdating = True 'д/включения обновления экрана
End Sub

Sub Tablica()
Dim iLastRow As Long
Dim n As Long
Dim iLR As Long
Application.ScreenUpdating = False
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With Worksheets("список_городов")
  iLR = .Cells(.Rows.Count, 1).End(xlUp).Row
     For n = 2 To iLR
      If InStr(1, .Cells(n, 1), "-") <> 0 Then
       Range("A2:A" & iLastRow).Replace what:=.Cells(n, 1), replacement:=.Cells(n, 2)
      End If
     Next
    Range("A2:A" & iLastRow).TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="-", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True
     For n = 2 To iLR
       If InStr(1, .Cells(n, 2), "_") <> 0 Then
          Range("A2:G" & iLastRow).Replace what:=.Cells(n, 2), replacement:=.Cells(n, 1)
       End If
     Next
 End With
Application.ScreenUpdating = True
End Sub

Sub RazdelitStroki()
Dim i As Long
Dim iLastRow As Long
Dim n As Long
Dim arr_M
Dim arr_O
Dim arr_P
Dim arr_Q
    iLastRow = Cells(Rows.Count, "M").End(xlUp).Row
    For i = iLastRow To 2 Step -1
      If InStr(1, Cells(i, "M"), Chr(10)) > 0 Then
        arr_M = Split(Cells(i, "M"), Chr(10))
        arr_O = Split(Cells(i, "O"), Chr(10))
        arr_P = Split(Cells(i, "P"), Chr(10))
        arr_Q = Split(Cells(i, "Q"), Chr(10))
        Cells(i, "M") = arr_M(0)
        Cells(i, "O") = arr_O(0)
        Cells(i, "P") = arr_P(0)
        Cells(i, "Q") = arr_Q(0)
        For n = 1 To UBound(arr_M)
          Rows(i + n).Insert
          Cells(i + n, "M") = arr_M(n)
          Cells(i + n, "O") = arr_O(n)
          Cells(i + n, "P") = arr_P(n)
          Cells(i + n, "Q") = arr_Q(n)
        Next
          Range("J" & i).Resize(UBound(arr_M) + 1).FillDown
          Range("K" & i).Resize(UBound(arr_M) + 1).FillDown
      End If
    Next
End Sub

Sub RazdelitStroki()
Dim i As Long
Dim iLastRow As Long
Dim n As Long
    iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    For i = iLastRow To 2 Step -1
      Rows(i + 1).Resize(4).Insert
      Range(Cells(i, "A"), Cells(i, "C")).Resize(5).FillDown
    Next
End Sub

Sub iKod()
Dim i As Long
Dim iLastRow As Long
Dim k As Long
Dim FoundArticul As Range
Dim FAdr As String
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
 Range("A1") = "Код"
 Range("B2:B" & iLastRow).ClearContents
 Range("H1:H" & iLastRow).ClearContents
    'уникальные из А в столбец H
 Range("A1:A" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True
 iLastRow = Cells(Rows.Count, "H").End(xlUp).Row
      For i = 2 To iLastRow                        'цикл по уникальным
        Set FoundArticul = Columns(1).Find(Cells(i, "H"), , xlValues, xlWhole)
         If Not FoundArticul Is Nothing Then       'первое совпадение
            FAdr = FoundArticul.Address            'адрес первого совпадения
            Cells(FoundArticul.Row, "B") = Cells(FoundArticul.Row, "A")
            k = 1
          Do                                       'ищем следующее совпадение
           Set FoundArticul = Columns(1).FindNext(FoundArticul)
           If FoundArticul.Address <> FAdr Then    'есть еще совпадение
             Cells(FoundArticul.Row, "B") = Cells(FoundArticul.Row, "A") & "-0" & k
             k = k + 1
           End If
          Loop While FoundArticul.Address <> FAdr  'ищем совпадения пока не дойдем до FAdr
         End If
      Next
        Range("H1:H" & iLastRow).ClearContents
End Sub

Set wbCurrent = ActiveWorkbook
Set wbReport = ActiveWorkbook

rngData.Copy 
wbReport.Worksheets(1).Cells(n + 1, 1).PasteSpecial xlPasteValues

Sub Zamena()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  For i = 2 To iLastRow
    If InStr(1, "холодильник , телевизор , автомобиль ", Cells(i, 1)) <> 0 Then
      Cells(i, 1) = "1"
    End If
  Next
End Sub

Sub iDogovor()
Dim i As Long
Dim n As Integer
Dim Criterij As String
Dim iName As String
Dim Sht As Worksheet
Application.ScreenUpdating = False
  Set Sht = ThisWorkbook.Worksheets("Исходник")
        Columns("AZ").ClearContents
     'отбор уникальных значений столбца B в столбец AZ
    Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                                  , CopyToRange:=Range("AZ1"), Unique:=True
     'количество уникальных значений
        n = Cells(Rows.Count, "AZ").End(xlUp).Row
    For i = 2 To n          'цикл по уникальным значениям
        Criterij = Sht.Cells(i, "AZ")
        iName = Criterij    'имя нового листа
     'ставим автофильтр по столбцу B
       Sht.Range("A1:AS" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row).AutoFilter 2, Criterij
     'копируем видимые строки в новый лист
        Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
        With Worksheets.Add(After:=Worksheets(Worksheets.Count))  'добавляет новый лист в конец
          .Range("A1:AS1").PasteSpecial xlPasteColumnWidths
          .Range("A1:AS1").PasteSpecial xlPasteFormats
          .Range("A1:AS1").PasteSpecial xlPasteValues
          Sht.AutoFilter.Range.AutoFilter
          .Name = iName
          .Range("A1").Select
        End With
    Next
      Sht.Activate
Application.ScreenUpdating = True
End Sub

Cells(i, 2) = .Replace(Cells(i, 1), "")

Cells(i, 2) = .Execute(Cells(i, 1))(0)