Function DelCount(s) As String
    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = ", \d+шт.+"
    If re.test(s) Then
        DelCount = re.Replace(s, "")
    Else
        DelCount = s
    End If
End Function

Sub Дублирование_строки()
    Dim FindWord As String, ReplaceWord As String, Rng As Range, firstAddres As String
    
    FindWord = Application.InputBox("Какое слово найти в 3-м столбце?", "Поиск слова")
    If FindWord = Empty Then Exit Sub
    ReplaceWord = Application.InputBox("На какое слово заменить?", "Поиск слова")
    If ReplaceWord = Empty Then Exit Sub
    
    With ActiveSheet
        Set Rng = .Columns(3).Find(FindWord, , xlFormulas, xlWhole) 'xlWhole -ячейка целиком (xlPart - часть ячейки)
        If Rng Is Nothing Then
            MsgBox "Слово '" & FindWord & "' не найдено в 3-м столбце!", vbExclamation, "Внимание"
            Exit Sub
        End If
        firstAddres = Rng.Address
        Do
            .Rows(Rng.Row).Copy
            .Rows(Rng.Row + 1).Insert Shift:=xlDown
            .Cells(Rng.Row + 1, 3) = ReplaceWord
            Set Rng = .Columns(3).FindNext(Rng)
        Loop Until Rng.Address = firstAddres
    End With
    MsgBox "Сделано!", vbInformation, "Конец"
End Sub

Private Sub btDelete_Click()
    Dim DeleteRec As Long
    Dim CheckDelete As VbMsgBoxResult
    
    DeleteRec = Me.LbEditCuct.ListIndex
    
    If DeleteRec = -1 Then
        MsgBox "No record has been selected for deletion", vbExclamation, "Delete Record?"
        Exit Sub
    Else
        CheckDelete = MsgBox("Are you sure you want to delere this record from the Master Data?", _
            vbExclamation + vbYesNo + vbDefaultButton1, "Delete Record?")
        If CheckDelete = vbNo Then Exit Sub
        DeleteRec = DeleteRec + 1
        shMaster.ListObjects("CustomerTable").ListRows(DeleteRec).Delete
        'обновляем таблицу в ListBox после удаления
        Me.LbEditCuct.RowSource = "CustomerTable"
    End If
End Sub

Private Sub Worksheet_Activate()
    Dim LastRow As Long, i As Long
       
    With Sheets("Оплата")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 3 To LastRow
            .Range("E" & i).value = Application.IfError(Application.VLookup(.Range("F" & i), Sheets("Начисления").Range("H2:N10000"), 7, 0), .Range("E" & i).value)
        Next
    End With
End Sub

If Sheets("Оплата").Range("E" & i).Value = "ФИО" Then
'тут ваша формула
End If

Sub Test()
Dim arrData As Variant, LastRow As Long, i As Long, arrOut As Variant, n As Long, Dict As Object

    'выбираем уникальные из столбца H
    Set Dict = CreateObject("Scripting.Dictionary")
    With Worksheets("Лист1")
        'определяем последнюю ячейку в столбце
        LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row
        'берём в массив все данные из столбца H
        arrData = .Range(.Cells(1, "H"), .Cells(LastRow, "H")).Value
    End With
    
    'создаём пустой массив под будущие результаты
    ReDim arrOut(1 To UBound(arrData), 1 To 1)
    n = 0
    'заносим в Словарь только уникальные значения
    For i = LBound(arrData) To UBound(arrData)
        If Not Dict.exists(arrData(i, 1)) Then
            Dict.Add arrData(i, 1), 0&
            n = n + 1
            arrOut(n, 1) = arrData(i, 1)
        End If
    Next i
    'выгружаем массив arrOut на Лист2
    With Worksheets("Лист2")
        'очищаем столбец G
        .Columns("G:G").Clear
        'всему столбцу присваиваем текстовый формат (чтобы не потерять нули перед цифрами)
        .Columns("G:G").NumberFormat = "@"
        .Range("G1").Resize(UBound(arrOut, 1), 1) = arrOut
    End With
    
    'выбираем уникальные из столбца R
    'всё тоже самое что и выше, только нужно заменить H на R и G на L
    '...
End Sub

DoEvents
UserForm.Repaint
DoEvents
DoEvents

Sub CreateTables()
    Dim arrData As Variant, arrNewTable As Variant, LO As ListObject, LastRow As Long, i As Long, n As Long

    With Worksheets("Sheet1")
        arrData = .Range("A1").CurrentRegion
    End With
    
    Application.ScreenUpdating = False
    With Worksheets("Sheet2")
        .Cells.Clear 'полностью очищаем Sheet2 (удаляем все данные с листа)
        For i = 2 To UBound(arrData)
            If arrData(i, 2) > 0 Then
                ReDim arrNewTable(1 To arrData(i, 2) + 1, 1 To 1)
                arrNewTable(1, 1) = "Column1"
                For n = 2 To UBound(arrNewTable)
                    arrNewTable(n, 1) = arrData(i, 1)
                Next n
                LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                If LastRow > 2 Then LastRow = LastRow + 1
                .Cells(LastRow, 1).Resize(UBound(arrNewTable, 1), 1) = arrNewTable
                .ListObjects.Add(xlSrcRange, .Range(.Cells(LastRow, 1).CurrentRegion.Address), False, xlYes, "TableStyleMedium2").Name = "Table" & .ListObjects.Count + 1
            End If
        Next i
    End With
    Application.ScreenUpdating = True
    
    MsgBox "Таблицы созданы!", vbInformation, "Конец"
End Sub

Sub one()
    Dim A As Range
    Set A = Worksheets("тест").Range("D2")
    If A = 300 Then A.MergeArea.EntireColumn.Hidden = Not A.MergeArea.EntireColumn.Hidden
End Sub