Sub ReplaceNumToText()
    Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object
    Dim sModuleName As String, sFullName As String
    Dim sProcLines As String
    Dim lLineNum As Long
    Dim sAdr$
    sAdr = Selection.Address(0, 0)
    sProcLines = "Sub Test()" & vbCrLf & _
                 "[" & sAdr & "] = [" & Chr(34) & Chr(39) & Chr(34) & "&" & sAdr & "]" & _
                 vbCrLf & "End Sub"
    'добавляем новый стандартный модуль в активную книгу
    Set objVBComp = ActiveWorkbook.VBProject.VBComponents.Add(1)
    'получаем ссылку на коды модуля
    Set objCodeMod = objVBComp.CodeModule
    'узнаем количество строк в модуле
    '(т.к. VBA в зависимости от настроек может добавлять строки деклараций)
    lLineNum = objCodeMod.CountOfLines + 1
    'вставляем текст процедуры в тело нового модуля
    objCodeMod.InsertLines lLineNum, sProcLines
    Application.Run objVBComp.Name & ".Test"
    objVBComp.Collection.Remove objVBComp

End Sub

Sub Color_SubStr_ССМ_2()
    Dim sSubStr As String    'искомое слово или фраза
    Dim lCol As Long    'номер столбца с просматриваемыми значениями
    Dim lLastRow As Long, li As Long
    Dim avArr, lr As Long
    Dim arr, lInStr&
    Dim t!
    lCol = Val(InputBox("Укажите номер столбца, в котором искать указанное значение", "Запрос параметра", 1))
    If lCol = 0 Then Exit Sub
    t = Timer
    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    'заносим в массив значения листа, в котором необходимо удалить строки
    arr = Cells(1, lCol).Resize(lLastRow, 2).Value
    'Получаем с ССМ значения, которые надо удалить в активном листе
    With Sheets("ССМ")    'Имя листа с диапазоном значений на удаление
        avArr = .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp))
    End With
    'удаляем
    For lr = 1 To UBound(avArr, 1)
        sSubStr = avArr(lr, 1)
        For li = 1 To lLastRow    'цикл с первой строки до конца
            lInStr = InStr(1, arr(li, 1), sSubStr, 1)
            If lInStr > 0 Then
                If lInStr = 1 Then
                    If Mid$(arr(li, 1), lInStr + Len(sSubStr), 1) = " " Then arr(li, 2) = "x"
                ElseIf lInStr - 1 + Len(sSubStr) = Len(arr(li, 1)) Then
                    If Mid$(arr(li, 1), lInStr - 1, 1) = " " Then arr(li, 2) = "x"
                Else
                    If Mid$(arr(li, 1), lInStr - 1, 1) = " " And Mid$(arr(li, 1), lInStr + Len(sSubStr), 1) = " " Then arr(li, 2) = "x"
                End If
            End If
        Next li
    Next lr
    Application.ScreenUpdating = 0
    For li = 1 To lLastRow    'цикл с первой строки до конца
        If Len(arr(li, 2)) Then Cells(li, 1).Interior.Color = 255
    Next
    Application.ScreenUpdating = 1
    Debug.Print Format(Timer - t, "0.0000")
End Sub

ActiveCell.Delete
ActiveSheet.UsedRange
?ActiveSheet.UsedRange.Address
$A$1

Private Sub CommandButton3_Click()
    Dim i&
    For i = ListBox1.ListCount - 1 To 0 Step -1
        If ListBox1.Selected(i) Then
            Sheets("Справочная_базис").ListObjects("Базис_tb").ListRows(i + 1).Delete
        End If
    Next
    On Error Resume Next
    Me.ListBox1.List = Sheets("Справочная_базис").ListObjects("Базис_tb").DataBodyRange.Value
    If Err Then Err.Clear: Me.ListBox1.Clear
    On Error GoTo 0
End Sub

Private Sub CommandButton2_Click()
    For i = 1 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) Then
            Sheets("лист2").ListObjects("Клуб46").ListRows(i + 1).Delete
            Me.ListBox1.List = Sheets("лист2").ListObjects("Клуб46").DataBodyRange.Value
            Exit For
        End If
    Next
End Sub

Sub мяу()
    Dim cl As Range
    For Each cl In Selection
        If cl.Interior.Pattern = xlNone Then cl.Value = Empty
    Next
End Sub