Страницы: 1
RSS
Нахождение уникальной строки с четырьмя уникальными ячейками и удалением повторяющихся
 
Добрый день.
У меня есть меняющийся со временем массив, состоящий из четырех столбцов с числами. Необходимо из всего массива выбрать уникальные строки с уникальными четырьмя числами и удалением строки даже если в ней повторяется хоть одна цифра. В приложении 3100 строк, я вручную делал, но очень долго. Я написал формулы, которые показывают дубляжи. Если в ручную удалять строчку из четырех цифр, то уникальная строка будет со всеми буквами "н" выше (Рис.1-7), но как я уже говорил вручную очень долго. В итоге получается, что каждая из этих четырех цифр по всем уникальным строчкам будут в единственном экземпляре. Подскажите, пожалуйста, как можно автоматизировать этот процесс. Эксель и картинки приклеить не могу, ибо они больше 100 Кб. Поэтому кидаю на яндекс диск. https://yadi.sk/d/FW3G5_pkUzy88Q
Благодарю.

Ametist69 написал:
Или проверку по строкам тоже делать? и если например в строке 1 все цифры уникальные, и в строке 2 все уникальные, но в строке 2 одна цифра есть и в строке 1, то строку 2 удаляем?
Да, именно так. У меня поиск повторок начинается с конца, то есть снизу массива и поиск повторок производится снизу наверх и учитывают все строки внизу. то есть 3100 строку не с чем сравнить, поэтому она уникальна, а 3099 строка, там последняя цифра дублируется, с цифрой в нижней строке, значит её удаляем.
Изменено: Taimu - 23.10.2019 14:33:42
 
Не совсем понятна задача, если в строке все 4 цифры уникальные то оставляем строку, а если не все 4 уникальные, то удаляем?
Верно?
Или проверку по строкам тоже делать? и если например в строке 1 все цифры уникальные, и в строке 2 все уникальные, но в строке 2 одна цифра есть и в строке 1, то строку 2 удаляем?
Изменено: Ametist69 - 22.10.2019 16:46:47
 
Taimu, здравствуйте! Сделайте файл-пример в которм будет понятно "как есть" и "как надо" и выложите тут без всяких ссылок
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Если задача стоит с проверкой по строкам тоже, как описал 2 вариант, то можно сделать вот так (только формулы вставьте как значения перед запуском макроса, а то долго будет отрабатывать, т.к. формулы будут пересчитываться при удалении каждой строки):
Код
Sub Test()

NameBook = ThisWorkbook.Name

RowsCount = Workbooks(NameBook).Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row

For x = 2 To RowsCount
    For y = 2 To 5
    Number = Cells(x, y).Value
        For a = x + 1 To RowsCount
            If Cells(a, 2) = Number Or Cells(a, 3) = Number Or Cells(a, 4) = Number Or Cells(a, 5) = Number Then
            Rows(a).Delete
            a = a - 1
            End If
            RowsCount = Workbooks(NameBook).Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
        Next
    Next
Next
            

End Sub

Изменено: Ametist69 - 22.10.2019 17:47:00
 
Цитата
Ametist69: формулы будут пересчитываться
этим управляет Application.Calculation
Код
Dim AC&
AC=Application.Calculation
Application.Calculation = xlCalculationManual 
'… КОД
Application.Calculation = AC
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Ametist69 написал:
Или проверку по строкам тоже делать? и если например в строке 1 все цифры уникальные, и в строке 2 все уникальные, но в строке 2 одна цифра есть и в строке 1, то строку 2 удаляем?
Да, именно так. У меня поиск повторок начинается с конца, то есть снизу массива и поиск повторок производится снизу наверх и учитывают все строки внизу. то есть 3100 строку не с чем сравнить, поэтому она уникальна, а 3099 строка, там последняя цифра дублируется, с цифрой в нижней строке, значит её удаляем.
 
Цитата
Jack Famous написал:
Taimu , здравствуйте! Сделайте файл-пример в которм будет понятно "как есть" и "как надо" и выложите тут без всяких ссылок
Добрый день. Я пытался скинуть сюда пример, но мне сказали, что файл максимум 100 Кб должен быть, у меня 700 Кб из за формул.
Я щас попытаюсь сделать поменьше и выложить как было и как надо.
 
Цитата
Ametist69 написал:
Если задача стоит с проверкой по строкам тоже, как описал 2 вариант, то можно сделать вот так (только формулы вставьте как значения перед запуском макроса, а то долго будет отрабатывать, т.к. формулы будут пересчитываться при удалении каждой строки):
У меня цифры как значения, только нахождение дублей как формулы, их удалить?
Прикладываю примеры "было", "стало"
 
Taimu, Не совсем понимаю, почему нужно чистить стоки, а не удалять.
Но если именно так как вы хотите, то вот код:
Код
Sub Test()

Dim AC&
AC = Application.Calculation
Application.Calculation = xlCalculationManual

NameBook = ThisWorkbook.Name

RowsCount = Workbooks(NameBook).Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row

For x = RowsCount To 2 Step -1
    If Cells(x, 2).Value = "" Then
    Cells(x, 2).Select
    Else
        For y = 2 To 5
        Number = Cells(x, y).Value
            For a = x - 1 To 2 Step -1
                If Cells(a, 2) = Number Or Cells(a, 3) = Number Or Cells(a, 4) = Number Or Cells(a, 5) = Number Then
                Range(Cells(a, 2), Cells(a, 5)).Clear
                End If
                RowsCount = Workbooks(NameBook).Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
            Next
        Next
    End If
Next

Application.Calculation = AC
            
End Sub
 
Цитата
Ametist69 написал:
Taimu , Не совсем понимаю, почему нужно чистить стоки, а не удалять.
Не не, можно просто удалять строки, это я для ручного способа написал, что строки чистить нужно, а не удалять. можно удалить и всё, чтобы остались только уникальные строки с уникальными цифрами.
 
Цитата
Ametist69 написал:
Если задача стоит с проверкой по строкам тоже, как описал 2 вариант, то можно сделать вот так (только формулы вставьте как значения перед запуском макроса, а то долго будет отрабатывать, т.к. формулы будут пересчитываться при удалении каждой строки):Код ? 123456789101112131415161718192021Sub Test() NameBook = ThisWorkbook.Name RowsCount = Workbooks(NameBook).Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row For x = 2 To RowsCount    For y = 2 To 5    Number = Cells(x, y).Value        For a = x + 1 To RowsCount            If Cells(a, 2) = Number Or Cells(a, 3) = Number Or Cells(a, 4) = Number Or Cells(a, 5) = Number Then            Rows(a).Delete            a = a - 1            End If            RowsCount = Workbooks(NameBook).Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row        Next    NextNext              End Sub

Изменено: Ametist69  - 22 Окт 2019 17:47:00
Этот код не совсем так работает как нужно.
 
Код
Sub ClearDuplicates()
    Dim r As Range, Calc&, i
    Set r = Cells(Rows.Count, 2).End(xlUp)
    With Application
        Calc = .Calculation: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = xlCalculationManual
        Do While r.Row > 2
            On Error Resume Next
            For i = 0 To 3
                With Range([B2], r.Offset(-1, 3))
                    .Replace r.Offset(, i), "=0/0", xlWhole
                    Intersect([B:Z], .SpecialCells(xlCellTypeFormulas, 16).EntireRow).ClearContents
                End With
            Next
            Set r = IIf(IsEmpty(r(0)), r.End(xlUp), r(0))
            DoEvents
        Loop
        .Calculation = Calc: .ScreenUpdating = 1: .EnableEvents = 1
    End With
End Sub

Код
Sub DeleteDuplicates()
    Dim r As Range, Calc&, i
    Set r = Cells(Rows.Count, 2).End(xlUp)
    With Application
        Calc = .Calculation: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = xlCalculationManual
        Do
            On Error Resume Next
            For i = 0 To 3
                With Range([B2], r.Offset(-1, 3))
                    .Replace r.Offset(, i), "=0/0", xlWhole
                    .SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete xlUp
                End With
                If r.Row = 2 Then Exit Do
            Next
            Set r = r(0)
            DoEvents
        Loop
        .Calculation = Calc: .ScreenUpdating = 1: .EnableEvents = 1
    End With
End Sub
 
Андрей Лящук, спасибо. Правда первый код, который не удаляет ячейки, дает 223 уникальных строки, а второй код дает 222 уникальных строки) и я так понял, что коды начинают своё выполнение снизу наверх.
 
Taimu, не злоупотребляйте цитированием.
 
Taimu, свои сообщения можно дополнять, не надо очередями... Цитата - не бездумная копия. Вернитесь, приведите сообщения в порядок.
 
с помощью кнопочки Изменить?
 
vikttur,а удалить то как сейчас мои сообщения?
 
Вы
Цитата
vikttur написал: свои сообщения можно дополнять
...а Вы опять на те же грабли...

Цитата
Taimu написал: удалить то как сейчас мои сообщения?
Вы отредактируйте сначала. Модераторы лишнее удалят
 
Андрей Лящук, а можешь сделать тоже самое, что и в Sub ClearDuplicates() только чтобы выполнение начиналось с начала списка, то есть сверху вниз?
 
Цитата
Ametist69 написал:
Sub Test() Dim AC&AC = Application.CalculationApplication.Calculation = xlCalculationManual NameBook = ThisWorkbook.Name RowsCount = Workbooks(NameBook).Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row For x = RowsCount To 2 Step -1    If Cells(x, 2).Value = "" Then    Cells(x, 2).Select    Else        For y = 2 To 5        Number = Cells(x, y).Value            For a = x - 1 To 2 Step -1                If Cells(a, 2) = Number Or Cells(a, 3) = Number Or Cells(a, 4) = Number Or Cells(a, 5) = Number Then                Range(Cells(a, 2), Cells(a, 5)).Clear                End If                RowsCount = Workbooks(NameBook).Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row            Next        Next    End IfNext Application.Calculation = AC             End Sub

Как сделать, чтобы этот код считал сверху вниз?
Страницы: 1
Наверх