Добрый день. У меня есть меняющийся со временем массив, состоящий из четырех столбцов с числами. Необходимо из всего массива выбрать уникальные строки с уникальными четырьмя числами и удалением строки даже если в ней повторяется хоть одна цифра. В приложении 3100 строк, я вручную делал, но очень долго. Я написал формулы, которые показывают дубляжи. Если в ручную удалять строчку из четырех цифр, то уникальная строка будет со всеми буквами "н" выше (Рис.1-7), но как я уже говорил вручную очень долго. В итоге получается, что каждая из этих четырех цифр по всем уникальным строчкам будут в единственном экземпляре. Подскажите, пожалуйста, как можно автоматизировать этот процесс. Эксель и картинки приклеить не могу, ибо они больше 100 Кб. Поэтому кидаю на яндекс диск. https://yadi.sk/d/FW3G5_pkUzy88Q Благодарю.
Ametist69 написал: Или проверку по строкам тоже делать? и если например в строке 1 все цифры уникальные, и в строке 2 все уникальные, но в строке 2 одна цифра есть и в строке 1, то строку 2 удаляем?
Да, именно так. У меня поиск повторок начинается с конца, то есть снизу массива и поиск повторок производится снизу наверх и учитывают все строки внизу. то есть 3100 строку не с чем сравнить, поэтому она уникальна, а 3099 строка, там последняя цифра дублируется, с цифрой в нижней строке, значит её удаляем.
Не совсем понятна задача, если в строке все 4 цифры уникальные то оставляем строку, а если не все 4 уникальные, то удаляем? Верно? Или проверку по строкам тоже делать? и если например в строке 1 все цифры уникальные, и в строке 2 все уникальные, но в строке 2 одна цифра есть и в строке 1, то строку 2 удаляем?
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
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
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 уникальных строки) и я так понял, что коды начинают своё выполнение снизу наверх.
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