Sub mgbeg()
    Лист1.Range("$A$3:$A$1373").Clear: Лист18.Range("$A$3:$A$1373").EntireRow.Copy
    Лист1.Range("$A$3:$A$1373").EntireRow.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub

    For Each iCells In Obl                                                                                                          'Запоминаем уникальные значения высоты строк в коллекцию
        On Error Resume Next: 
        If iCells <> "" Then Coll.Add CStr(iCells.RowHeight), CStr(iCells.RowHeight)
        If NewObl Is Nothing Then Set NewObl = iCells Else Set NewObl = Union(NewObl, iCells)
        On Error GoTo 0
    Next iCells: 
    iОбласть(i) = NewObl.Address
В итоге получается 2-а массива (высота строк, адрес области)

NewObl.Select

Debug.Print NewObl.Address

Columns(2).Select

Sub SetClipboardText()                                 'Запись в буфер обмена
    Dim MyData As DataObject, txt As String

    txt = "Проверка данных"
    
    Set MyData = New DataObject
    MyData.SetText txt                                              'Запись в буфер обмена
    MyData.PutInClipboard
    
    MyData.GetFromClipboard
    txt = MyData.GetText(1)
    Debug.Print txt
End Sub

Проверка данных

txt = MyData.GetText(1)

??

Dim cl As Range, Text$
.....
Set cl = List.Range(Cells(1, 1), Cells(5, 5)).Cells.Find(What:=Text, LookAt:=xlPart)
    Do Until cl Is Nothing
        cl.Characters(InStr(cl, Text), Len(Text)).Insert "###"
        Set cl = List.Range(Cells(1, 1), Cells(5, 5)).Cells.Find(What:=Text, LookAt:=xlPart)
    Loop

Public Function FileToRAR()
    FilePath = Application.GetOpenFilename("Files,*.xl*;*.doc*", 0, "Выберите файлы для обработки", "Выбрать", True)
    WinRarAppPath = "C:\Program Files\WinRAR\WinRAR.exe"   'указываем папку с Winrar
    WinRarApp = WinRarAppPath & " A -ep"
    ArhiveName = "D:\Test.rar"а

'Действие 1. Архивация
    FileToRAR = Shell(WinRarApp & " """ & ArhiveName & """ """ & FilePath & """ ", vbNormalFocus)  'Архивируем все файлы списка

'Действие 2. что то делаем с ArhiveName

End Function

Application.Wait Time:=Now + Выдержка

Sub zamena_word()
    Dim i As Integer, j As Integer, MaxStr As Integer, NumTab As Integer
    Dim names, raswireniya, raswir, newword, fullfilename, filename  As String
    Dim isName As Variant
    Dim Workbook As Object
    Dim iFilenum As Long, iErr As Long
    
    filenamedoc = Application.GetOpenFilename("Файл открытия(*.docx),*.docx, All Files (*.*),*.*", , "Выберите Файл с исходными данными", "Выбрать", False)    'выбираем путь к файлу и запоминаем его
    If filenamedoc = "False" Then MsgBox "Файл не выбран": Metka = False: Exit Sub Else: Metka = True
    
'==================== Копируем файл шаблона в нужное место
    'Имя файла
    Set Workbook = CreateObject("Scripting.FileSystemObject")
    fullfilename = Workbook.GetFileName(filenamedoc)  'полное имя файла (с расширением)
    raswireniya = Split(fullfilename, ".")
    raswir = "." & raswireniya(UBound(raswireniya)) 'получаем расширение файла
    filename = Replace(fullfilename, raswir, "")    'имя файла без расширения
    newword = Replace(filenamedoc, raswir, "_new_copy" & raswir)    'создаем новое имя файла, + "_new_copy" к названию
    Set Workbook = Nothing
    
    'Проверяем открыт ли файл
    On Error Resume Next
    iFilenum = FreeFile()
    Open filenamedoc For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
    On Error GoTo 0

    Select Case iErr
    Case 70:    MsgBox ("Выбранный Вами документ активирован," & Chr(13) & "данный документ необходимо закрыть."): End      'документ открыт
    End Select

    FileCopy filenamedoc, newword

'==================== Открываем файл============
    Dim WA As Object, WD As Object
    Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word
    WA.Visible = True 'показать Word - True
    Set WD = WA.Documents.Open(newword)
    If WD.TrackRevisions = True Then WD.TrackRevisions = Not WD.TrackRevisions 'если режим рецензии в файле включен, отключаем его

'==================== Разделяем таблицу при необходимости ================
MaxStr = 20
NumTab = 1
Label1:
'Debug.Print Now: Application.SendKeys "^g ^a {DEL}" 'Очищаем Immediate Window
If NumTab <= WD.Tables.Count Then
    For i = NumTab To WD.Tables.Count
        If WD.Tables(i).Rows.Count > MaxStr Then 'Проверяем количество строк
            For j = MaxStr To WD.Tables(i).Rows.Count
                On Error GoTo Errors1
                Debug.Print WD.Tables(i).Cell(j, 1).Range.Text, WD.Tables(i).Cell(j, 2).Range.Text
                If InStr(WD.Tables(i).Cell(j, 2).Range.Text, "ВЛ ") > 0 Then
                    WD.Tables(i).Cell(j, 1).Select    'Выделяем строку таблицы
                    WD.Application.Selection.SplitTable 'Разделяем по выделенной строке
                    NumTab = i + 1: GoTo Label1
                End If
Errors1: Err.Clear  'Очищаем ошибку
            Next j
        End If
    Next i
End If

'==================== Сохраняем word=============
    WD.Save
    WA.Quit
'================ Открываем созданный файл=======
'    Open_file (newword)
'================================================
    filenamedoc = newword
End Sub

WD.Range(WD.Tables(1).Cell(4, 1).Range.Start, WD.Tables(1).Cell(4, 1).Range.End).Rows.SplitTable

    With Cells 'меняем ### на абзац
                .Replace What:="###", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    End With

Sub Целое()
   Параметр = Fix(0.15 / 0.05)
End Sub

......
            Dim pShell As Object
            Dim pFolder As Object, pFile As Object
            Set pShell = CreateObject("Shell.Application")
       Файл_v_zip = Файл & ".zip"
            Set pFolder = pShell.Namespace(Файл_v_zip & "\word")
            For Each pFile In pFolder.Items
                If Right(pFile.Path, Len("settings.xml")) = "settings.xml" Then Exit For
            Next pFile
      
      'как в данном месте из (Файл_v_zip & "\word) удалить найденный файл settings.xml
      'что то вроде Kill pFile.Path - вариант не прошел      

            pShell.Namespace(Файл_v_zip & "\word").CopyHere Файл2, 16

Private Sub Add_file()
    Dim file As String
    file = Application.GetOpenFilename("All Files (*.doc*; *.pdf; *.rtf; *.txt; *.odt; *.xl*; *.jp*; *.bmp; *.dib; *.gif; *.tif*; *.png),*.doc*; *.pdf; *.rtf; *.txt; *.odt; *.xl*; *.jp*; *.bmp; *.dib; *.gif; *.tif*; *.png", , "Âûáåðèòå ôàéë", "Âûáðàòü", False)
    If file = "False" Then Exit Sub
    
    OLEObjects.Add(FileName:=file, Link:=False, DisplayAsIcon:=True, IconFileName:= _
    "C:\PROGRA~2\MICROS~1\Office14\WINWORD.EXE", IconIndex:=0, IconLabel:="").Select
 End Sub 

Dim li As Long 
For li = 1 To 5 
if ActiveSheet.DrawingObjects("CheckBox" & li).Object.Value = 1 then 
'что-то там делаем 
End If 
Next li