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