Sub X____Копирование_коробок_по_началу_и_концу()
    Dim dataArray As Range
    Dim searchArray As Range
    Dim pasteRange As Range
    Dim startIndex As Long
    Dim endIndex As Long
    Dim copyRange As Range
    Dim i As Long

    ' Запрос выбора данных массива
    On Error Resume Next
    Set dataArray = Application.InputBox("Выберите диапазон ячеек с данными", "Выбор массива", Type:=8)
    On Error GoTo 0
    If dataArray Is Nothing Then Exit Sub ' Выход из макроса, если пользователь не выбрал диапазон

    ' Если выбран столбец, то расширяем диапазон до последней заполненной ячейки
    If dataArray.Columns.Count = 1 Then
        Set dataArray = dataArray.Resize(dataArray.Rows.Count - WorksheetFunction.CountBlank(dataArray))
    End If

    ' Запрос выбора диапазона для поиска
    On Error Resume Next
    Set searchArray = Application.InputBox("Выберите диапазон ячеек, в котором нужно искать значения", "Выбор диапазона для поиска", Type:=8)
    On Error GoTo 0
    If searchArray Is Nothing Then Exit Sub ' Выход из макроса, если пользователь не выбрал диапазон

    ' Запрос выбора места для вставки результатов
    On Error Resume Next
    Set pasteRange = Application.InputBox("Выберите ячейку, в которую нужно вставить результат", "Выбор места вставки", Type:=8)
    On Error GoTo 0
    If pasteRange Is Nothing Then Exit Sub ' Выход из макроса, если пользователь не выбрал ячейку для вставки

    ' Поиск начального и конечного индексов в массиве
    For i = 1 To dataArray.Rows.Count Step 2
        If Not IsEmpty(dataArray.Cells(i, 1)) And Not IsEmpty(dataArray.Cells(i + 1, 1)) Then
            startIndex = Application.Match(dataArray.Cells(i, 1).Value, searchArray, 0)
            endIndex = Application.Match(dataArray.Cells(i + 1, 1).Value, searchArray, 0)
            If startIndex > 0 And endIndex > 0 Then
                ' Объединение диапазона ячеек, которые нужно скопировать
                Set copyRange = searchArray.Range(searchArray.Cells(startIndex, 1), searchArray.Cells(endIndex, searchArray.Columns.Count))
                
                ' Копирование значений и форматирования в выбранную пользователем ячейку
                copyRange.Copy
                pasteRange.PasteSpecial Paste:=xlPasteAll
                Set pasteRange = pasteRange.Offset(copyRange.Rows.Count, 0)
            End If
        End If
    Next i
End Sub

Sub CopyDuplicates()
Dim sourceRange As Range
Dim destinationRange As Range
Dim searchRange As Range
Dim lastRow As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim sourceValue As Variant
Dim destinationValue As Variant
Dim searchValue As Variant
Dim copyRange As Range
Dim copyCell As Range

' Предоставление выбора источника данных
Set sourceRange = Application.InputBox("Выберите диапазон источника данных:", Type:=8)

' Предоставление выбора диапазона для поиска дубликатов
Set searchRange = Application.InputBox("Выберите диапазон для поиска дубликатов:", Type:=8)

' Предоставление выбора диапазона для вставки результатов
Set destinationRange = Application.InputBox("Выберите диапазон для вставки результатов:", Type:=8)

' Нахождение последней строки в диапазоне поиска
lastRow = searchRange.Rows.Count + searchRange.Row - 1

' Обход каждой ячейки в диапазоне поиска
For i = searchRange.Row To lastRow
searchValue = searchRange.Cells(i, 1).Value

' Проверка наличия повторяющегося значения в диапазоне поиска
If WorksheetFunction.CountIf(searchRange, searchValue) > 1 Then
' Обход каждой ячейки в источнике данных
For j = sourceRange.Row To sourceRange.Rows.Count + sourceRange.Row - 1
sourceValue = sourceRange.Cells(j, 1).Value

' Сравнение значения в источнике с значением в диапазоне поиска
If sourceValue = searchValue Then
' Формирование диапазона для копирования
If copyRange Is Nothing Then
Set copyRange = sourceRange.Cells(j, 1)
Else
Set copyRange = Union(copyRange, sourceRange.Cells(j, 1))
End If
Else
' Вставка диапазона для копирования, если он не пустой
If Not copyRange Is Nothing Then
' Копирование диапазона в указанный диапазон назначения
Set copyCell = destinationRange.Cells(k + 1, 1)
copyRange.Copy copyCell

' Увеличение индекса для следующей строки назначения
k = k + copyRange.Rows.Count

' Очистка диапазона для следующего поиска
Set copyRange = Nothing
End If
End If
Next j

' Вставка диапазона для копирования, если он не пустой после обхода всех значений источника данных
If Not copyRange Is Nothing Then
' Копирование диапазона в указанный диапазон назначения
Set copyCell = destinationRange.Cells(k + 1, 1)
copyRange.Copy copyCell

' Увеличение индекса для следующей строки назначения
k = k + copyRange.Rows.Count

' Очистка диапазона для следующего поиска
Set copyRange = Nothing
End If
End If
Next i

' Вставка последнего диапазона для копирования, если он не пустой
If Not copyRange Is Nothing Then
' Копирование диапазона в указанный диапазон назначения
Set copyCell = destinationRange.Cells(k + 1, 1)
copyRange.Copy copyCell

' Увеличение индекса для следующей строки назначения
k = k + copyRange.Rows.Count
End If
End Sub