Sub FindArticul()
Dim i As Long
Dim iLastRow As Long
Dim cell As Range
Dim List1 As Worksheet
  Set List1 = ThisWorkbook.Worksheets("Лист1")
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Range("B3:C" & iLastRow).ClearContents
 With List1
   For i = 3 To iLastRow
    Set cell = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
    If Not cell Is Nothing Then
       Cells(i, "B") = cell.Offset(, 1)     'наименование
       Cells(i, "C") = cell.Offset(, 2)     'ячейка хранения
    Else
      MsgBox "На листе1 нет артикула: " & Cells(i, "A")
    End If
   Next
 End With
End Sub

Function iRU(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .ignorecase = True
     .Pattern = "//([A-Z\.]+)(?=/)"
   If .test(cell) Then
     iRU = .Execute(cell)(0).submatches(0)
   Else
     iRU = ""
   End If
 End With
End Function

Function iModel(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = ": ?([A-Z0-9]+)(?=,)"
   If .test(cell) Then
     iModel = .Execute(cell)(0).submatches(0)
   Else
     iModel = ""
   End If
 End With
End Function

Sub FindLastWord()
Dim i As Long
Dim arr
Dim LastWord As String
Dim FoundWord As Range
    Columns("A:B").Interior.ColorIndex = 2
  For i = 2 To 11
    arr = Split(Cells(i, "B"), " ")
      LastWord = arr(UBound(arr))
      Set FoundWord = Columns(5).Find(LastWord, , xlValues, xlPart)
      If Not FoundWord Is Nothing Then
        Range("A" & i & ":B" & i).Interior.ColorIndex = 6
      End If
  Next
End Sub

Sub iPoiskTown()
Dim j As Long
Dim k As Long
Dim n As Long
Dim FoundCell As Range
Dim arr
   arr = Array("Москва", "Петербург", "Адлер")
 For k = 1 To 3                           'цикл по столбцам
     For j = 0 To UBound(arr)             'цикл по городам
         Set FoundCell = Columns(k).Find(arr(j), , xlValues, xlWhole)
       If Not FoundCell Is Nothing Then
        n = n + 1                         'счетчик вхождений городов в столбец
       Else
         n = 0
         Exit For
       End If
     Next           'следующий город
     If n = UBound(arr) + 1 Then
        MsgBox "Все города находятся в " & Cells(1, k)
        Exit Sub
     End If
 Next               'следующий столбец
End Sub

iFoundRng.Offset(, 1).Resize(, k).Value = arrZam

iFoundRng.Offset(, 1).Resize(, k).Value = iFoundRng.Offset(, 1).Resize(, k).Value

Sub ConcatMonth()
Dim iBeginDate As Date
Dim iEndDate As Date
Dim j As Long
Dim jLastColumn As Long
  iBeginDate = Range("B3")
  If Day(iBeginDate) <> 1 Then
    MsgBox "В ячейке В3 не начальная дата месяца"
    Exit Sub
  End If
  jLastColumn = Cells(3, Columns.Count).End(xlToLeft).Column
    Rows("1:2").UnMerge
    Rows("1:2").ClearContents
    Rows("1:2").NumberFormat = "@"
    iEndDate = DateSerial(Year(iBeginDate), Month(iBeginDate) + 1, 1) - 1
  For j = 2 To jLastColumn
    Select Case Month(iEndDate)
      Case 1, 3, 5, 7, 8, 10, 12
        Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)).MergeCells = True
          Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)) = "21-31"
      Case 4, 6, 9, 11
        Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)).MergeCells = True
          Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)) = "21-30"
      Case 2
        Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)).MergeCells = True
          If Day(iEndDate) = 28 Then
            Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)) = "21-28"
          Else
            Range(Cells(2, j + 20), Cells(2, j + Day(iEndDate) - 1)) = "21-29"
          End If
    End Select
       Range(Cells(2, j), Cells(2, j + 9)).MergeCells = True
       Range(Cells(2, j), Cells(2, j + 9)) = "01-10"
       Range(Cells(2, j + 10), Cells(2, j + 19)).MergeCells = True
       Range(Cells(2, j + 10), Cells(2, j + 19)) = "11-20"
       Range(Cells(1, j), Cells(1, j + Day(iEndDate) - 1)).MergeCells = True
       Range(Cells(1, j), Cells(1, j + Day(iEndDate) - 1)) = Format(Cells(3, j), "MMMM YYYY")
        j = j + Day(iEndDate) - 1
        iEndDate = DateSerial(Year(iEndDate), Month(iEndDate) + 2, 1) - 1
  Next
End Sub

Function iResult(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\((01|21)\)"
   If .test(cell) Then
     iResult = .Replace(cell, "$1")
   Else
     iResult = cell
   End If
 End With
End Function

Sub СКРЫТЬ()
    'Rows("2:19").Select
    'Selection.EntireRow.Hidden = True
    Range("B1:B19").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
    'Range("A1").Select
End Sub
Sub ОТКРЫТЬ()
    'Rows("2:19").Select
    'Selection.EntireRow.Hidden = False
    'Range("A1").Select
    Range("B1:B19").EntireRow.Hidden = False
End Sub

Sub iBlocks()
Dim i As Long
Dim iLastRow As Long
Dim Rng As Range
  iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
  Range("B2:B" & iLastRow).Font.ColorIndex = 1
  Range("B2:B" & iLastRow).Interior.ColorIndex = 2
  For Each Rng In Range("B2:B" & iLastRow).SpecialCells(2, 2).Areas
    For i = 1 To Rng.Count - 1
      If Rng.Cells(i) = Rng.Cells(i + 1) Then
      Else
        Exit For
      End If
    Next
      If i = Rng.Count Then
        Rng.Cells.Font.ColorIndex = 3
        Rng.Cells.Interior.ColorIndex = 6
      End If
  Next
End Sub

Sub Limits()
Dim FoundLimit As Range
Dim FirstAdr As String
Dim BeginDiapazon As Long
Dim EndDiapazon As Long
Dim iLastRow As Long
Dim iLastRow_1 As Long
Dim j As Integer
Dim limitNomer As Long
    With ThisWorkbook.Worksheets("Лист_1")
      iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("G2:M" & iLastRow).ClearContents        ' очищаем
            iLastRow_1 = .Cells(.Rows.Count, "G").End(xlUp).Row + 1
    Set FoundLimit = .Columns("A").Find("Лимиты", , xlValues, xlWhole)
       If Not FoundLimit Is Nothing Then
             FirstAdr = FoundLimit.Address    'адрес первого вхождения
          Do
             limitNomer = FoundLimit.Offset(-1)
               BeginDiapazon = FoundLimit.Row + 1
             Set FoundLimit = .Columns("A").Find("Лимиты", After:=FoundLimit)
             If FoundLimit.Address <> FirstAdr Then
               EndDiapazon = FoundLimit.Row - 1
             Else
               EndDiapazon = iLastRow
             End If
        For j = BeginDiapazon To EndDiapazon    ' цикл по диапазону наименований
            If IsDate(Cells(j, 1)) Then
                .Cells(iLastRow_1, "G") = Int(.Cells(j, 1))   '
                .Cells(iLastRow_1, "H") = .Cells(j, 1) - Int(.Cells(j, 1))
                .Cells(iLastRow_1, "I") = .Cells(j, 2)
                .Cells(iLastRow_1, "J") = .Cells(j, 3)
                .Cells(iLastRow_1, "K") = .Cells(j, 4)
                .Cells(iLastRow_1, "L") = .Cells(j, 5) '
                .Cells(iLastRow_1, "M") = limitNomer                     '
                iLastRow_1 = iLastRow_1 + 1
            End If
        Next
          Loop While FoundLimit.Address <> FirstAdr
       End If
    End With
End Sub

Function iResult(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d+"
   If .test(cell) Then
     iResult = .Replace(cell, "")
   Else
     iResult = cell
   End If
 End With
End Function

Criteria1:= _
        "=" & Replace(CDbl(Range("A1")), ",", ".")

ActiveSheet.Range("A3:B14").AutoFilter Field:=2, Criteria1:="=" & CDbl(g1)

    ActiveSheet.Range("$A$2:$B$14").AutoFilter Field:=2, Criteria1:=Array( _
        "2025", "2026", "2027", "2028"), Operator:=xlFilterValues

Sub insertrow()
Dim tbl As ListObject
Dim n As Long
Dim k As Long
Dim i As Long
  Set tbl = ActiveSheet.ListObjects(1)
  For n = tbl.DataBodyRange.Rows.Count To 1 Step -1
    k = tbl.DataBodyRange(n, 5)
    For i = 1 To k - 1
      tbl.ListRows.Add (n + i)
      tbl.DataBodyRange(n + i, 1) = tbl.DataBodyRange(n, 1) + i
      tbl.DataBodyRange(n + i, 2) = tbl.DataBodyRange(n, 2)
      tbl.DataBodyRange(n + i, 3) = tbl.DataBodyRange(n, 3)
      tbl.DataBodyRange(n + i, 4) = tbl.DataBodyRange(n, 4) / k
      tbl.DataBodyRange(n + i, 4).NumberFormat = "#,###.00"
    Next
      tbl.DataBodyRange(n, 4) = tbl.DataBodyRange(n + 1, 4)
      tbl.DataBodyRange(n, 4).NumberFormat = "#,###.0"
  Next n

End Sub

Sub Sbor()
Dim FoundPart As Range
Dim WSH As Worksheet
Dim iLastRow As Long
Dim iLR As Long
    iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
        If iLastRow <> 1 Then Range("A2:E" & iLastRow).ClearContents
    For Each WSH In Worksheets  'цикл по всем листам книги
        If WSH.Name <> "сборка" Then
With WSH
Set FoundPart = .Rows(1).Find("партия", , xlValues, xlWhole)
    If Not FoundPart Is Nothing Then
      iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
      iLR = .Cells(.Rows.Count, 2).End(xlUp).Row
      Cells(iLastRow, 1).Resize(iLR - 2) = .Name
      .Range("A3:B" & iLR).Copy Cells(iLastRow, 2)
      FoundPart.Offset(2).Resize(5, 2).Copy Cells(iLastRow, 4)
    End If
End With
        End If
    Next WSH
End Sub

Function iResult(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .ignorecase = True
     .Pattern = "[А-ЯЁ]+©"
   If .test(cell) Then
     iResult = .Replace(cell, "")
   Else
     iResult = cell
   End If
 End With
End Function

Sub PoiskFIO_Date()
Dim j As Long
Dim iLastRow As Long
Dim Found_Name As Range
Dim FAdr As String
Dim iDateMax As Date
   iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   Range("D2:E" & iLastRow).ClearContents
   Range("A1:A" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("D1"), Unique:=True
   iLastRow = Range("D2").End(xlDown).Row
 For j = 2 To iLastRow
   Set Found_Name = Columns("A").Find(Cells(j, "D"), , xlValues, xlWhole)
    If Not Found_Name Is Nothing Then
      FAdr = Found_Name.Address
     iDateMax = Found_Name.Offset(, 1)
      Do
        Set Found_Name = Columns("A").FindNext(Found_Name)
          If Found_Name.Offset(, 1) > iDateMax Then
            iDateMax = Found_Name.Offset(, 1)
          End If
      Loop While Found_Name.Address <> FAdr
          Cells(j, 5) = iDateMax
     End If
 Next
End Sub

Sub iTitle()
Dim i As Long
Dim iLastRow As Long
Dim arr
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
   For i = 3 To iLastRow
     If InStr(1, Cells(i, "A"), Chr(10)) <> 0 Then
       arr = Split(Cells(i, "A"), Chr(10))
           Cells(i, "B") = arr(UBound(arr))
     End If
   Next
End Sub

Sub UniqMail()
Dim arr
Dim dic As Object
Dim i As Long
Dim iLastRow As Long
Dim iMail As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "<(.+)>"
      iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
     Range("D2:D" & iLastRow).ClearContents
     Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
     arr = Range("A2:A" & iLastRow).Value
  For i = 1 To UBound(arr)
    If .test(arr(i, 1)) Then
      iMail = .Execute(arr(i, 1))(0).submatches(0)
      dic.Item(iMail) = dic.Item(iMail) + 1
    End If
  Next i
   Range("D2").Resize(dic.Count, 2) = Application.Transpose(Array(dic.keys, dic.Items))
 End With
End Sub

Function iDigits(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d+[А-Я]?"
     If .Test(cell) Then
       iDigits = .Execute(cell)(0)
       If IsNumeric(iDigits) Then
         iDigits = CDbl(iDigits)
       End If
     Else
       iDigits = ""
     End If
 End With
End Function

Sub DigitLetter()
Dim i As Long
Dim iLastRow As Long
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
With CreateObject("VBScript.RegExp")
  .Global = True
  .Pattern = "(\d+)"
  For i = 1 To iLastRow
    If .Test(Cells(i, 1)) Then
      Cells(i, 2) = WorksheetFunction.Trim(.Replace(Cells(i, 1), " $& "))
    End If
  Next
End With
End Sub

Sub iLevel()
  Cells(8, 7) = Cells(8, 6).IndentLevel
End Sub

Function iNumberRoom(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .MultiLine = True
     .Pattern = "Количество комнат: (.+)$"
   If .test(cell) Then
     iNumberRoom = .Execute(cell)(0).SubMatches(0)
   Else
     iNumberRoom = ""
   End If
 End With
End Function

Function iSquare(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .MultiLine = True
     .Pattern = "Общая площадь: (.+)$"
   If .test(cell) Then
     iSquare = .Execute(cell)(0).SubMatches(0)
   Else
     iSquare = ""
   End If
 End With
End Function

 .Pattern = "\d{2}:\d{2}:\d{7}:\d{3,4}"

Function iKN(cell$)
 With CreateObject("VBScript.RegExp")
     .Global = True
     .Pattern = "\d{2}:\d{2}:\d{7}:\d{4}"
   If .test(cell) Then
     iKN = .Execute(cell)(0)
   Else
     iKN = ""
   End If
 End With
End Function