Excel Макросы: Перенос выбранных записей с расцеплением и с проверкой

[Посетитель]

Здравствуйте,уважаемые участники форума!
Прошу Вашей помощи.
проверка записей при переносе на дублирование    
   как сейчас
сейчас при выбранных 3 строк  на листе "база"происходит проверка на дубли на листе "Реестр Д"   
и если есть хоть одно совпадение,то выдается сообщение и процесс останавливается.   
   как желательно
при выбранных 3 строк  на листе "база"происходит проверка на дубли на листе "Реестр Д"   
и если есть хоть одно совпадение,то проверяется следующие записи и при отсутствия дублей переносится     
на лист "Реестр Д".Сообщение о наличие таких записей выдается только при совпадении   
всех записей.   


[вложение удалено администратором]

[Администратор]

Макрос

Sub Расцепка()
Dim v_Is, v_M
Dim Rng As Range, iVal As String
Dim r As Integer
Dim v As Integer, boolWasCopy As Boolean
With Sheets("база")
.Select
r = Cells(Rows.Count, 1).End(xlUp).row
'исправить
      'If Not IsEmpty(.Cells(Range("v").Column)) Then MsgBox "Строк для обработки не выделено", vbCritical: Exit Sub
'Exit Sub
'End If
For Each x In .Range(Cells(5, 2), Cells(r, 2)).SpecialCells(2)
If Right(x.Offset(, 4), 1) = ";" Then x.Offset(, 4) = Left(x.Offset(, 4), Len(x.Offset(, 4)) - 1) 'Удаляем последнюю точку с запятой
v_Is = Split(Trim(x.Offset(, 3)), ";")    'записываем расцепленную строку "испонительная схема" в массив
v_M = Split(Trim(x.Offset(, 13)), ";")    'записываем расцепленную строку "материалы" в массив
Sheets("Реестр Д").Select
With Sheets("Реестр Д") 'запись на лист
'................................................
iVal = x.Offset(, 1)
Set Rng = Sheets("Реестр Д").Columns(3).Find(iVal, , xlFormulas, xlWhole) 'осуществляем поиск. Вместо xlWhole, можно использовать xlPart

    ' Если нашли, то переход к следующей строке на листе "база".
    If Not Rng Is Nothing Then
        GoTo metkaNextRow
    End If

    ' Пометка, что какая-то запись копировалась.
        ' В неё будет каждый раз записываться True для каждой копируемой строки.
    boolWasCopy = True

'.............................................
  r1 = .Cells(.Rows.Count, 2).End(xlUp).row + 1
  'Запись в столб "B"
  .Cells(r1, 2) = "АктР. " & x.Offset(, 2) 'наименование работ
  .Cells(r1 + 1, 2).Resize(UBound(v_Is)) = Application.Transpose(v_Is) 'испонительная схема
  .Cells(r1 + 1 + UBound(v_Is), 2).Resize(UBound(v_M) + 1) = Application.Transpose(v_M) 'материалы
  'запись в столб "C"
  .Cells(r1, 3) = x.Offset(, 1) 'номер акта
  .Range(.Cells(r1 + 1, 3), .Cells(r1 + 1 + UBound(v_Is) + UBound(v_M), 3)) = "приложение к акту № " & x.Offset(, 1) 'приложение
   .Cells(r1, 2).Borders.LineStyle = xlContinuous ' границы
     .Cells(r1, 2).Font.Color = 15773696
      .Cells(r1, 2).Font.Size = 12
       .Cells(r1, 2).Font.Bold = True
    .Cells(r1, 3).Borders.LineStyle = xlContinuous ' границы
     .Cells(r1, 3).Font.Color = 15773696
    .Cells(r1, 4).Borders.LineStyle = xlContinuous ' границы
     .Cells(r1, 4).Font.Color = 15773696
'запись в столб "D"
  .Range(.Cells(r1, 4), .Cells(r1 + 1 + UBound(v_Is) + UBound(v_M), 4)) = x.Offset(, 5) 'Организация
  End With
metkaNextRow:
Next x
End With

    ' Проверка, было ли что-нибудь скопировано.
    If boolWasCopy = False Then
        MsgBox "Все выбранные значения уже есть.", vbExclamation, "Ошибка"
        Sheets("база").Select
        Exit Sub
    End If

Beep
End Sub

[свернуть]

[Посетитель]

Спасибо! Оперативно и главное получил желаемый результат.