Function iChislo(cell$)
 With CreateObject("VBScript.RegExp")
 '    .Global = True
     .Pattern = "(""-"",\s?){1,}""(\d+,\d+)""\]$"
   If .test(cell) Then
     iChislo = .Execute(cell)(0).SubMatches(1)
   Else
     iChislo = ""
   End If
 End With
End Function

Sub JSht_()
Dim myCell As Range
Dim firstAddress As String
  With Rows(2)
    Set myCell = .Find("Сумм*", , , xlPart)
        If Not myCell Is Nothing Then
            firstAddress = myCell.Address
        End If
    Do
      'делаете с найденным столбцом myCell.Column необходимые действия


      Set myCell = .Find("Сумм*", After:=myCell)
    Loop While myCell.Address <> firstAddress
   End With
End Sub

Function iDate(cell As String) As Date
Dim temp As String
Dim iMonth As String
Dim n As Integer
   temp = cell
  n = Len(Split(temp, " ")(0))
     iMonth = Split(temp, " ")(1)
    Select Case iMonth
     Case "Jan": Mid(temp, n + 2, 3) = "янв"
     Case "Feb": Mid(temp, n + 2, 3) = "фев"
     Case "Mar": Mid(temp, n + 2, 3) = "мар"
     Case "Apr": Mid(temp, n + 2, 3) = "апр"
     Case "May": Mid(temp, n + 2, 3) = "май"
     Case "Jun": Mid(temp, n + 2, 3) = "июн"
     Case "Jul": Mid(temp, n + 2, 3) = "июл"
     Case "Aug": Mid(temp, n + 2, 3) = "авг"
     Case "Sep": Mid(temp, n + 2, 3) = "сен"
     Case "Oct": Mid(temp, n + 2, 3) = "окт"
     Case "Nov": Mid(temp, n + 2, 3) = "ноя"
     Case "Dec": Mid(temp, n + 2, 3) = "дек"
    End Select
  iDate = CDate(temp)
End Function

Function iDate(cell$) As Date
Dim mo As Object
 With CreateObject("VBScript.RegExp")
     .Global = True
   If InStr(1, cell, ".") > 0 Then
      .Pattern = "(([0-2]?\d{1})|([3][0,1]{1}))\.[0,1]?\d{1}\.(([1]{1}[9]{1}[9]{1}\d{1})|([2-9]{1}\d{3}))"
     If .test(cell) Then
       iDate = .Execute(cell)(0)
     Else
       iDate = ""
     End If
   ElseIf InStr(1, cell, "/") > 0 Then
      .Pattern = "([0,1]?\d{1})\/(([0-2]?\d{1})|([3][0,1]{1}))\/[0,1]?\d{1}\/(([1]{1}[9]{1}[9]{1}\d{1})|([2-9]{1}\d{3}))"
        iDate = .Replace(cell, "$2.$1")
      Else
     iDate = ""
   End If
 End With
End Function

    Set FD = Application.FileDialog(msoFileDialogFilePicker)
    With FD

        .InitialFileName = ThisWorkbook.Path

Function GetNomer(stroka As String)
Dim arr
  arr = Split(stroka)
  GetNomer = arr(UBound(arr))
End Function

PasteSpecial xlPasteColumnWidths

Sub ClearForm()
 Dim ws As Worksheet
 Dim sh As Shape
    Set ws = ThisWorkbook.Sheets("start")
    For Each sh In ActiveSheet.Shapes
       If sh.Name Like "Check Box *" Then
            sh.Delete
        End If
    Next sh
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub 'выделено больше одной ячейки
  If Not Intersect(Target, Columns("P")) Is Nothing Then
    Cells.Interior.ColorIndex = xlColorIndexNone
    Range(Cells(Target.Row, 1), Cells(Target.Row, 30)).Interior.Color = RGB(234, 244, 234) 'светло-зеленый
  Else
    Cells.Interior.ColorIndex = xlColorIndexNone
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub 'выделено больше одной ячейки
  If Not Intersect(Target, Columns("P")) Is Nothing Then
    Cells.Interior.ColorIndex = xlColorIndexNone
    Range(Cells(Target.Row, 1), Cells(Target.Row, 30)).Interior.Color = RGB(234, 244, 234) 'светло-зеленый
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub 'выделено больше одной ячейки
  If Not Intersect(Target, Columns("P")) Is Nothing Then
    Range(Cells(Target.Row, 1), Cells(Target.Row, 30)).Interior.Color = RGB(234, 244, 234) 'светло-зеленый
  End If
End Sub

If Target.Cells.Count > 1 Then Exit Sub 'выделено больше одной ячейки
    If Not Intersect(Target, Columns("P")) Is Nothing Then

Range(Cells(Target.Row,1), Cells(Target.Row,30)).Interior.Color = RGB(234, 244, 234) 'светло-зеленый

Sub ifound()
Dim FoundCell As Range
Dim List1 As Worksheet
Dim Tsena As Double
Set List1 = ThisWorkbook.Worksheets("Лист1")
    Set FoundCell = Columns("A").Find(List1.Range("E4"), , xlValues, xlPart)
    List1.Range("S4") = Cells(FoundCell.Row, "L")
    MsgBox "Значение VIN " & List1.Range("E4") & " находится в строке: " & FoundCell.Row
End Sub

If ActiveWorkbookt.ProtectContents = True Then

Function LastSkobki(cell$) As String
Dim mo As Object
Dim n As Integer
 With CreateObject("VBScript.RegExp")
   .Global = True
   .Pattern = "\((.+?)\)"
   Set mo = .Execute(cell)
     LastSkobki = Replace(cell, mo(mo.Count - 1), "")
 End With
End Function

'Иванов Иван Иванович               Выделить И.О.Фамилия
Function iFIO(cell As String) As String
 With CreateObject("VBScript.RegExp")
     .Global = True
     .IgnoreCase = False
     .Pattern = "([А-ЯЁ][а-яё ]+)([А-ЯЁ])[а-яё ]+([А-ЯЁ])[а-яё ]+"
     If .test(cell) Then
       iFIO = .Replace(cell, "$2.$3. $1")
     End If
 End With
End Function

ActiveSheet.Pictures.Insert

ActiveSheet.Pictures.Add

Columns(iLastCol).AutoFit