Макрос
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