Здравствуйте, подскажите что поправить в коде, что б макрос корректно отрабатывал, есть колонка исследования, он оттуда берет данные и создает новые листы с названием, проблема в том что он повторно добавляет туда эти же строки, как бы сделать что б все были уникальные, на вкладке реестр идет добавление каждый раз строк, если необходимо в колонке D значения всегда будут уникальные
Код
Sub перенос()
Dim i As Long, j As Integer, ws As Worksheet, aws As Worksheet, x As Range
Set x = Rows(1).Find("исследование", , , xlWhole)
If x Is Nothing Then Exit Sub Else j = x.Column
Application.ScreenUpdating = False: Set aws = Sheets("реестр")
For i = aws.Cells(Rows.Count, j).End(xlUp).Row To 2 Step -1
If aws.Cells(i, j) <> "" Then
On Error Resume Next: Set ws = ThisWorkbook.Sheets(CStr(aws.Cells(i, j)))
If Err <> 0 Then
Set ws = Sheets.Add: ActiveSheet.Name = aws.Cells(i, j): On Error GoTo 0
aws.Cells.Copy
ws.Cells.PasteSpecial Paste:=xlPasteColumnWidths
ws.Cells.PasteSpecial Paste:=xlPasteFormats
End If
W = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 'номер строки куда вставлять
aws.Range("A" & i & ":V" & i).Copy ws.Cells(W, 1)
aws.Range("Y" & i & ":W" & i).Copy ws.Cells(W, "Y")
End If: Next
End Sub
Sub перенос()
Dim W As Long
Dim i As Long
Dim j As Integer
Dim ws As Worksheet
Dim aws As Worksheet
Dim x As Range
Set x = Rows(1).Find("исследование", , , xlWhole)
If x Is Nothing Then Exit Sub Else j = x.Column
Application.ScreenUpdating = False
Set aws = Sheets("реестр")
For i = aws.Cells(Rows.Count, j).End(xlUp).Row To 2 Step -1
If aws.Cells(i, j) <> "" Then
Set ws = Nothing
On Error Resume Next
Set ws = ThisWorkbook.Sheets(CStr(aws.Cells(i, j)))
On Error GoTo 0
If ws Is Nothing Then
Set ws = Sheets.Add: ActiveSheet.Name = aws.Cells(i, j): On Error GoTo 0
aws.Cells.Copy
ws.Cells.PasteSpecial Paste:=xlPasteColumnWidths
ws.Cells.PasteSpecial Paste:=xlPasteFormats
End If
W = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 'номер строки куда вставлять
aws.Range("A" & i & ":V" & i).Copy ws.Cells(W, 1)
aws.Range("Y" & i & ":W" & i).Copy ws.Cells(W, "Y")
ws.Range("$A$1:$W$12").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23), Header:=xlNo
End If
Next
End Sub