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

Sub test()
Dim arr
Dim dic As Object
Dim i As Long
Dim j As Long
Dim iLastRow As Long
    iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
     Set dic = CreateObject("Scripting.Dictionary"): dic.comparemode = 1
  For i = 2 To iLastRow
     arr = Split(Range("B" & i).Value, ", ")
    For j = 0 To UBound(arr)
      dic.Item(arr(j)) = dic.Item(arr(j))
    Next j
  Next i
   Range("C1").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
End Sub

Option Explicit
Sub FindValue()
Dim c As Range
Dim i As Long
Dim firstAddress As String
Dim ek As Range
    With Worksheets(1).Range("A1:A16")
      For i = 1 To Cells(Rows.Count, "G").End(xlUp).Row
        Set ek = Worksheets(1).Range("G" & i)
        Set c = .Find(ek, LookIn:=xlValues, Lookat:=xlPart)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                c.Value = ek
                'i = i + 1
                Set c = .FindNext(c)
            'Loop While Not c Is Nothing
            Loop While c.Address <> firstAddress
        End If
      Next
    End With
End Sub

Sub iSum()
Dim Rng As Range
  For Each Rng In Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row).SpecialCells(2, 1).Areas
    Rng.Cells(0, 2) = WorksheetFunction.Sum(Rng)
    Rng.Cells(0, 2).NumberFormat = "#,##0"
  Next
End Sub