Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование строк в новый лист, исключая дублирование данных
 
#1
03.06.2021 12:49:09
Здравствуйте, подскажите что поправить в коде, что б макрос корректно отрабатывал, есть колонка исследования, он оттуда берет данные и создает новые листы с названием, проблема в том что он повторно добавляет туда эти же строки, как бы сделать что б все были уникальные, на вкладке реестр идет добавление каждый раз строк, если необходимо в колонке 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
Изменено: vikttur - 03.06.2021 13:07:32
 
 
 
#2
03.06.2021 14:02:17
Код
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
 
 
 
#3
03.06.2021 15:00:57
Вроде все работает, благодарю!!!, надо потестить будет
 
 
 
Страницы: 1
Наверх