Private Sub UserForm_Initialize()
Dim  i As Long
With Me.ListBox1
'      For i = .ListCount - 1 To 0 Step -1
      For i = 0 To 5
         .List(i, 0) = (Format(.List(i, 0), "0%"))
      Next i
End With
  

Sub ПронумероватьСтолбецА()
Application.ScreenUpdating = False 'чтоб не моргало выключаем скрин
 Application.EnableEvents = False

 Dim i As Long, LastRow As Long
 LastRow = Cells(Rows.Count, 1).End(xlUp).Row
 Cells(LastRow + 1, 1).Select
 
 'Cells(LastRow + 1, 1).Value = ..... макрос выбора уникального номера ....
 


Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Sub Поиск ()
    Dim strText As String, arr()
    Dim lr As Long, i As Long, x
    Rows.Hidden = False
    strText = ActiveSheet.OLEObjects("Textbox1").Object.text
    If strText = "" Then
        Exit Sub
    End If
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    arr() = Range("B1:B" & lr).Value
    For i = 4 To UBound(arr)
        If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then
            Rows(i).Hidden = True
            Else
            Rows(i).Hidden = False
        End If
    Next i
    
    x = dhCountVisibleCells(Range("A5:S500"))
    If x = 0 Then
    Rows.EntireRow.Hidden = False
    MsgBox "Текст не найден !"
    Else
'    ActiveWindow.ScrollColumn = 8
    End If
End Sub

If InStr(1, arr(i, 1), strText, vbTextCompare) = 0 Then

Private Type RECT
        Left   As Long
        Top   As Long
        Right   As Long
        Bottom   As Long
End Type
Private Declare Function SendMessage Lib "user32 " Alias "SendMessageA " ( _
        ByVal hwnd As Long, _
        ByVal wMsg As Long, _
        ByVal wParam As Long, _
        lParam As Any) As Long
Private Const EM_GETRECT = &HB2
Private Const EM_SETRECTNP = &HB4

Sub VerMiddleText(mText As TextBox)
        If mText.MultiLine = False Then Exit Sub
        Dim rc     As RECT, tmpTop       As Long, tmpBot       As Long
        SendMessage mText.hwnd, EM_GETRECT, 0, rc
        With Me.Font
            .Name = mText.Font.Name
            .Size = mText.Font.Size
            .Bold = mText.Font.Bold
        End With
        tmpTop = ((rc.Bottom - rc.Top) - _
                (mText.Parent.TextHeight("H ") \ Screen.TwipsPerPixelY)) \ 2 + 2
        tmpBot = ((rc.Bottom - rc.Top) + _
                (mText.Parent.TextHeight("H ") \ Screen.TwipsPerPixelY)) \ 2 + 2
        rc.Top = tmpTop
        rc.Bottom = tmpBot
        mText.Alignment = vbCenter
        SendMessage mText.hwnd, EM_SETRECTNP, 0&, rc
        mText.Refresh
End Sub

Private Sub Form_Load()
        VerMiddleText (text1)
End Sub

Private Sub Form_Load()
        VerMiddleText (text1)
End Sub

Private Sub UserForm_Activate()
Dim text1 As String
text1 = TextBox1.Value
VerMiddleText (text1)
End Sub

Sub ПоставитьЗащитуЛиста()
ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, _
DrawingObjects:=True, Contents:=True, Scenarios:=True, _
AllowInsertingRows:=True, AllowDeletingRows:=True
End Sub

Sub ВставитьСтроку()
Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect Password:="123"
'ActiveCell.EntireRow.Select
'Selection.Locked = False
'On Error Resume Next
'ActiveSheet.Paste
'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteAll
'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues
'Rows(ActiveCell.Row).PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Rows(ActiveCell.Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.Protect Password:="123", UserInterfaceOnly:=True, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowInsertingRows:=True, AllowDeletingRows:=True
'On Error GoTo 0
Application.EnableEvents = True
'Application.ScreenUpdating = True
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(ActiveCell, Range("D4:D50")) Is Nothing Then

'''''вносить и дополнять данные в ячейке можно,
'''''а стирать частично или полностью только через MsgBox ?

Select Case MsgBox("Вы пытаетесь изменить введенные данные! Изменить или удалить внесенные данные ?", 33, "Предупреждение !") 
Case 1 ' Ок

Case 2 ' Отмена 

End Select

End If
End Sub 

Sub Макрос1()
Dim i As Shape
If Not Intersect(ActiveCell, Range("D4:D500")) Is Nothing Then

Set i = ActiveSheet.Shapes("Picture 1")
a = ActiveSheet.Name & "!" & ActiveCell.Address
ActiveSheet.Hyperlinks.Add Anchor:=i, Address:="", SubAddress:=a, ScreenTip:="Всплывающая подсказка 1"
Set i = Nothing

End If
End Sub

Sub Макрос2()
Dim i As Shape

Set i = ActiveSheet.Shapes("Picture 1")
ActiveSheet.Hyperlinks.Add Anchor:=i, Address:="", SubAddress:="", ScreenTip:=""
Set i = Nothing

'удаляем записью из рекодера не работает и выделение фигуры не нужно
'ActiveSheet.Shapes.Range(Array("Picture 1")).Select
'Selection.ShapeRange.Item(1).Hyperlink.Delete

End Sub

Private Sub ListBox33_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
a = ListBox33.Text
If Not Intersect(Range("A2:H1000"), ActiveCell) Is Nothing Then
    ActiveCell.Value = ActiveCell.Value & " " & a & "."
End If
End Sub

Sub ЖирныйТекст()
Dim LastRow As Long, r As Long
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
For r = 2 To LastRow

'как в этом месте прописать данное условие ?
If Cells(r, 2) Like "//" '''''''''''.Font.Bold 

End If
Next
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
a = ListBox1.Text
If Not Intersect(Range("E2:E500"), ActiveCell) Is Nothing Then
If ListBox1.Text = "Информация ТЕКСТ ЖИРНЫЙ:" Then
ActiveCell.Value = ActiveCell.Value & " " & a
Else
ActiveCell.Value = ActiveCell.Value & " " & a
End If
End If
End Sub

Sub Copy()
Application.ScreenUpdating = False 'чтоб не моргало выключаем скрин
Application.DisplayAlerts = False

Call Создать_папку_ДАТА 'создаем папку ДАТА в корне файла

Dim strFileName As String 'имя файла который создаем Дата_27.02.2017_20.35.xls
strFileName = ThisWorkbook.Path & "\ДАТА\Дата_" & Format(Date, "dd.mm.yyyy") & "_" & Format(Time, "HH.mm") & ".xls"

Call КопированиеДанных 'копируем таблицу с отфильтрованными значениями
ActiveWorkbook.SaveAs strFileName

Application.CutCopyMode = False

Application.DisplayAlerts = True
Application.ScreenUpdating = True 'включаем скрин
End Sub

Sub КопированиеДанных()
    Workbooks.Add xlWBATWorksheet
    ActiveSheet.Name = "Результаты_копирования" 'обзываем лист новой книги
    ThisWorkbook.ActiveSheet.Range("A1:G500").Copy 'диапазон копирования
    ActiveSheet.[A1].PasteSpecial
    ActiveSheet.[A1].PasteSpecial xlPasteValues 'копируем значения
    ActiveSheet.[A1].PasteSpecial xlPasteFormats 'копируем формат
    ActiveSheet.[A1].PasteSpecial Paste:=xlPasteColumnWidths 'корпируем ширину столбцов
    ActiveSheet.Rows("1:500").EntireRow.AutoFit 'выравнивание высоты строки
End Sub

Sub Создать_папку_ДАТА()
    On Error Resume Next
    Const folder$ = "ДАТА" ' название основной папки
    MkDir ThisWorkbook.Path & "\" & folder$ ' создаём папку в директории, если её ещё нет
 End Sub

Function Фамилия_ИО$(Фамилия_Имя_Отчество$)   ' преобразует Иванов Иван Иванович —> Иванов И.И.
   Dim iArr, NotFirst As Boolean
   For Each iArr In Split(Application.Trim(Фамилия_Имя_Отчество))
      If NotFirst Then
         Фамилия_ИО = Фамилия_ИО & UCase$(Left$(iArr, 1)) & "."
      Else
         Фамилия_ИО = StrConv(iArr, vbProperCase) & " "
         NotFirst = True
      End If
   Next
   Фамилия_ИО = Trim(Фамилия_ИО)
End Function
Sub PreobrazovatText2()
'If (текст в активной ячейке не содержит кавычки " и количество слов между пробелами равно трем =3 словам )  Then
ActiveCell.Offset(0, 1).Value = Фамилия_ИО$(ActiveCell)
'Else
'Exit Sub
End Sub

Private Sub ListBox5_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
a = ListBox5.Text
If Not Intersect(Range("A1:D100" _
'пробуем вставить закомментированную строку
, ActiveCell) Is Nothing Then _
'пробуем вставить закомментированную строку
    ActiveCell.Value _
'пробуем вставить закомментированную строку
   = ActiveCell.Value _ 
   & "." & " " & a
End If
End Sub