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

Cells(4, iLastCol).EntireColumn.AutoFit

Dim iLastCol As Integer
iLastCol = Cells(4 , Columns.Count).End(xlToLeft).Column

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
If Target.Count > 1 Then Exit Sub
  If Target.Value > 0 And Target.Value < =31 Then
    Target = DateSerial(Year(Now), Month(Now), Target)
    Target.NumberFormat = "dd.mm.yyyy"
  Else
    Target = ""
  End If
      Application.EnableEvents = True
End Sub

Option Explicit

Sub iName_a1()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim iName As String
Dim iListName As String
Dim Wb As Workbook
Dim iSh As Worksheet
  With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Range("M1:M" & iLastRow).Clear
    Range("B2:B" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("M2"), Unique:=True
    Range("M2") = "Уникальные номера"
    iListName = Split(ActiveWorkbook.Name, ".")(0)  'лист по названию активной книги
     Set iSh = ThisWorkbook.Worksheets("Лист1")
   For i = 3 To Cells(Rows.Count, "M").End(xlUp).Row
     iName = Cells(i, "M")
       'проверяем есть файл с таким именем в папке с текущим файлом
     If FileExists(ThisWorkbook.Path & "\" & iName & ".xlsx") Then     'есть такой файл
        If ActiveSheet.AutoFilterMode = False Then
            Range("B2:K2").AutoFilter
        Else
            If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
        End If
      Set Wb = Workbooks.Open(FileName:=ThisWorkbook.Path & "\" & iName & ".xlsx")
        Wb.Worksheets(iListName).Activate
          iLR = Cells(Rows.Count, "B").End(xlUp).Row + 1
          With iSh.AutoFilter.Range
            .Range("B2").AutoFilter Field:=1, Criteria1:=iName
            .Offset(1).SpecialCells(xlCellTypeVisible).Copy Cells(iLR, 2)
          End With
        Wb.Close saveChanges:=True
        If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
     Else
       MsgBox "В папке с исходным файлом нет файла: " & ThisWorkbook.Path & "\" & iName & ".xlsx"
     End If
   Next
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
  End With
End Sub


'Проверка существования файла
Function FileExists(ByVal FileName As String) As Boolean
   FileExists = Len(Dir(FileName)) > 0
End Function