Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Как быстро и легко в VBA проверить выделенный диапазон на уникальность ???
 
#1
09.03.2010 20:11:16
Как быстро и легко в VBA проверить выделенный диапазон на уникальность ???  
Выделен на листе диапазон (из какогота количества строк и одного столбца) и нужно быстро узнать - есть ли в нем повторяющиеся элементы.  
Есть наметка, но незнаю как оформить..  
Считаем количество строк выделенного диапазона -    
     iSStrok = Selection.Rows.Count ' кол. строк  
Потом через меню Данные/автофильтр/Расширенный фильтр - "только уникальные записи" - узнать количество строк этого "уникального" диапазона.  
И если первоначальное количество строк = уникальному -    
     MsgBox "диапазон с уникальными значениями"  
А в противном случае -    
     MsgBox "имеются повторения значений"
 
 
 
#2
09.03.2010 20:38:37
можно. но операции с листом - обычно не самый оптимальный вариант для "легко и быстро". Хотя тут фиг его знает)  
 
вообщем выкладывайте пример.
 
 
 
#3
09.03.2010 21:11:07
Option Explicit  
 
Sub pp()  
Dim r1 As Range, r2 As Range  
Dim t1 As Long, t2 As Long  
Set r1 = Selection  
t1 = r1.Rows.Count  
r1.AdvancedFilter Action:=xlFilterInPlace, Unique:=True  
Set r2 = r1.SpecialCells(xlCellTypeVisible)  
t2 = r2.Rows.Count  
If t1 <> t2 Then  
MsgBox "Неуникально"  
Else  
MsgBox "Уникально"  
End If  
ActiveSheet.ShowAllData  
End Sub  
 
 
 
Как скажете)
 
 
 
#4
09.03.2010 21:16:43
Sub pp()  
Dim r1 As Range, r2 As Range  
Dim t1 As Long, t2 As Long  
Dim uniq As New Collection, i As Long  
Set r1 = Selection  
t1 = r1.Count  
On Error Resume Next  
For i = 1 To t1  
uniq.Add r1.Cells(i, 1), CStr(r1.Cells(i, 1))  
Next i  
t2 = uniq.Count  
If t1 <> t2 Then  
MsgBox "Неуникально"  
Else  
MsgBox "Уникально"  
End If  
ActiveSheet.ShowAllData  
End Sub  
 
 
а мне так все таки больше нравится) поуниверсальней, все таки диапазон может и не быть столбцом.
 
 
 
#5
09.03.2010 21:29:11
первый даже еще вот так пилить надо  
Sub ppo()  
Dim r1 As Range, r2 As Range  
Dim t1 As Long, t2 As Long  
Set r1 = Selection.Offset(-1, 0).Resize(Selection.Rows.Count + 1, 1)  
t1 = r1.Rows.Count  
r1.AdvancedFilter Action:=xlFilterInPlace, Unique:=True  
Set r2 = r1.SpecialCells(xlCellTypeVisible)  
t2 = r2.Count  
If t1 <> t2 Then  
MsgBox "Неуникально"  
Else  
MsgBox "Уникально"  
End If  
ActiveSheet.ShowAllData  
End Sub  
 
 
The_Prist: почему если данные макрос применять на числах первого столбца то r2.rows.count выдает "2" ?
 
 
 
#6
09.03.2010 21:35:43
и если данные начинаются с первой ячейки - расширенный фильтр не отрабатывает. Вообщем решение хоть и красивое, но с кучей оговорок, о которых надо знать
 
 
 
#7
09.03.2010 21:37:26
Dophin, у Вас в примере все равно столбец. Лучше так:  
Sub pp()  
Dim r1 As Range, r2 As Range, r3 As Range  
Dim t1 As Long, t2 As Long  
Dim uniq As New Collection, i As Long  
Set r1 = Selection  
t1 = r1.Count  
On Error Resume Next  
For Each r3 In r1.Cells  
uniq.Add r3, CStr(r3.Value)  
Next  
t2 = uniq.Count  
If t1 <> t2 Then  
MsgBox "Неуникально"  
Else  
MsgBox "Уникально"  
End If  
End Sub  
 
И селекшн может быть несвязным
Bite my shiny metal ass!      
 
 
 
#8
09.03.2010 21:47:53
ага. спасибо)
 
 
 
#9
09.03.2010 22:54:45
Dophin  
Лузер™  
The_Prist  
Спасибо ребята, очень помогли!  
 
остановился на этом :  
 
Sub pp()  
Dim r1 As Range, r2 As Range  
Dim t1 As Long, t2 As Long  
Dim uniq As New Collection, i As Long  
Set r1 = Selection  
t1 = r1.Count  
On Error Resume Next  
For i = 1 To t1  
uniq.Add r1.Cells(i, 1), CStr(r1.Cells(i, 1))  
Next i  
t2 = uniq.Count  
If t1 <> t2 Then  
MsgBox "Неуникально"  
Else  
MsgBox "Уникально"  
End If  
ActiveSheet.ShowAllData  
End Sub  
 
вполне достаточно.  
Еще раз СПАСИБО!
 
 
 
#10
09.03.2010 23:15:42
Nord, в выложенном вами коде можно удалить    
 
r2 As Range и ActiveSheet.ShowAllData
 
 
 
#11
09.03.2010 23:43:33
Предлагаю доработать вариант с коллекцией  
 
Option Explicit  
 
Private Declare Function GetTickCount Lib "kernel32" () As Long  
 
Sub CheckUnique()  
   Dim Rng As Range, iCell As Range  
   Dim Num1 As Long, Num2 As Long  
   Dim iCollection As New Collection  
 
   Dim StartTime As Long, FinishTime As Long  
   StartTime = GetTickCount    'засекаем время  
 
   If TypeName(Selection) <> "Range" Then MsgBox "Выберите диапазон ячеек!", 48, "": Exit Sub  
         
   Set Rng = Selection.Cells  
   If WorksheetFunction.CountA(Rng) = 0 Then  
       MsgBox "Выделенный диапазон не содержит данных!", 48, "Ошибка"  
       Exit Sub  
   End If  
     
   Num1 = Rng.Count  
     
   On Error Resume Next  
   For Each iCell In Rng  
       iCollection.Add iCell, CStr(iCell.Value)  
   Next  
     
   Num2 = iCollection.Count  
     
   FinishTime = GetTickCount - StartTime  
     
   If Num1 <> Num2 Then  
       MsgBox "В выделенном диапазоне имеются повторения!" & _  
       Chr(10) & "Количество повторов: " & Num1 - Num2 & _  
       Chr(10) & "Затрачено времени: " & FinishTime / 1000 & " сек.", 48, "Проверка на уникальность"  
   Else  
       MsgBox "В выделенном диапазоне повторения нет!" & Chr(10) & "Затрачено времени: " & FinishTime / 1000 & " сек.", 64, "Проверка на уникальность"  
   End If  
End Sub
 
 
 
#12
09.03.2010 23:53:58
А ещё можно выделить красным цветом повторяющиеся ячейки ) Ну, чтобы было легче их найти )  
 
Option Explicit  
 
Private Declare Function GetTickCount Lib "kernel32" () As Long  
 
Sub CheckUnique()  
   Dim Rng As Range, iCell As Range, Num1 As Long, Num2 As Long, iCollection As New Collection  
   Dim StartTime As Long, FinishTime As Long  
     
   StartTime = GetTickCount  
   If TypeName(Selection) <> "Range" Then MsgBox "Выберите диапазон ячеек!", 48, "": Exit Sub  
   Set Rng = Selection.Cells  
   If WorksheetFunction.CountA(Rng) = 0 Then  
       MsgBox "Выделенный диапазон не содержит данных!", 48, "Ошибка"  
       Exit Sub  
   End If  
   Num1 = Rng.Count  
   On Error Resume Next  
   For Each iCell In Rng  
       iCollection.Add iCell, CStr(iCell.Value)  
       If Err <> 0 Then  
           iCell.Interior.ColorIndex = 3  
           Err.Clear  
       End If  
   Next  
   Num2 = iCollection.Count  
   FinishTime = GetTickCount - StartTime  
   If Num1 <> Num2 Then  
       MsgBox "В выделенном диапазоне имеются повторения!" & _  
       Chr(10) & "Количество повторов: " & Num1 - Num2 & _  
       Chr(10) & "Затрачено времени: " & FinishTime / 1000 & " сек.", 48, "Проверка на уникальность"  
   Else  
       MsgBox "В выделенном диапазоне повторения нет!" & Chr(10) & "Затрачено времени: " & FinishTime / 1000 & " сек.", 64, "Проверка на уникальность"  
   End If  
End Sub
 
 
 
#13
10.03.2010 00:12:07
А если не нужно учитывать пустые ячейки, то вот так будет работать ещё быстрее  
 
Option Explicit  
 
Private Declare Function GetTickCount Lib "kernel32" () As Long  
 
Sub CheckUnique()  
   Dim Rng As Range, iCell As Range, Num1 As Long, Num2 As Long, iCollection As New Collection  
   Dim StartTime As Long, FinishTime As Long  
 
   StartTime = GetTickCount  
   If TypeName(Selection) <> "Range" Then MsgBox "Выберите диапазон ячеек!", 48, "": Exit Sub  
   If WorksheetFunction.CountA(Selection) = 0 Then  
       MsgBox "Выделенный диапазон не содержит данных!", 48, "Ошибка"  
       Exit Sub  
   End If  
   'Set Rng = Selection.Cells 'все ячейки, включая пустые  
   Set Rng = Selection.SpecialCells(xlCellTypeConstants) 'только ячейки с данными  
   Num1 = Rng.Count  
   On Error Resume Next  
   For Each iCell In Rng  
       iCollection.Add iCell, CStr(iCell.Value)  
       If Err <> 0 Then  
           iCell.Interior.ColorIndex = 3  
           Err.Clear  
       End If  
   Next  
   Num2 = iCollection.Count  
   FinishTime = GetTickCount - StartTime  
   If Num1 <> Num2 Then  
       MsgBox "В выделенном диапазоне имеются повторения!" & _  
              Chr(10) & "Количество повторов: " & Num1 - Num2 & _  
              Chr(10) & "Затрачено времени: " & FinishTime / 1000 & " сек.", 48, "Проверка на уникальность"  
   Else  
       MsgBox "В выделенном диапазоне повторения нет!" & _  
              Chr(10) & "Затрачено времени: " & FinishTime / 1000 & " сек.", 64, "Проверка на уникальность"  
   End If  
End Sub
 
 
 
#14
10.03.2010 00:38:56
Из цикла лучше выходить сразу же, как только обнаружен повторный ключ в коллекции/словаре. Два примера с использованием колекции и словаря:  
 
' With Collection  
Function IsUniq(Rng As Range) As Boolean  
 Dim Arr()  
 Arr() = Rng.Value  
 On Error GoTo exit_  
 With New Collection  
   For Each x In Arr()  
     If Len(x) > 0 Then .Add 0, Str(x)  
   Next  
 End With  
 IsUniq = True  
exit_:  
End Function  
 
' With Dictionary  
Function IsUniq1(Rng As Range) As Boolean  
 Dim Arr()  
 Arr() = Rng.Value  
 On Error GoTo exit_  
 With CreateObject("Scripting.Dictionary")  
   For Each x In Arr()  
     If Len(x) > 0 Then .Add x, 0  
   Next  
 End With  
 IsUniq1 = True  
exit_:  
End Function  
 
Sub Test_IsUniq()  
 Debug.Print IsUniq(Range("A1:B100"))  
End Sub  
 
Sub Test_IsUniq1()  
 Debug.Print IsUniq1(Range("A1:B100"))  
End Sub
 
 
 
#15
10.03.2010 00:47:29
Желательно еще объявить переменную X  
вместо: Dim Arr()  
должно быть: Dim Arr(), x  
 
P.S. Спасибо модераторам за то, что многократно подправляли подобные опечатки! :-)
 
 
 
#16
24.11.2012 23:47:21
{quote}{login=}{date=10.03.2010 12:12}{thema=}{post}А если не нужно учитывать пустые ячейки, то вот так будет работать ещё быстрее  
{/post}{/quote}  
 
А можно дополнить этот скрипт, чтобы он ещё и на разных листах совпадения искал? Имеем на РАЗНЫХ листах одинаковые ячейки - подчёркиваем и их тоже.
 
 
 
Страницы: 1
Наверх