Немного ошибся в кодах выше:
строку
1.
Cells(first, 2 ).Value = "unique"
надо заменить на строку
1.
Cells(first, uniq).Value = "unique"
Переделал вариант от ZVI для универсальности:
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
Sub uniqueFormula()
target = InputBox("What Column Inspected? (Letter)", "target", "A", 1500 , 2000 )
sdvig = (InputBox("What Offset For Mark? (Number)", sdvig, 10 , 1500 , 2000 )) * 1
With Application
calc_status = .Calculation
.Calculation = xlManual
.ScreenUpdating = False
't = Timer
rcnt = ActiveSheet.UsedRange.Rows.Count 'scitaem cislo obrabativaemih jaceek
first = ActiveSheet.UsedRange.Row
With Range(target & LTrim(Str(first)) & ":" & target & LTrim(Str(rcnt))).Offset(, sdvig)
.Formula = "=IF(MATCH(" & target & first & ", $" & target & "$" & "1" & ":" & target & first & ", 0)=ROW(),""unique"","""")"
.Value = .Value
End With
'ActiveSheet.Range(target & LTrim(Str(first)) & ":" & target & LTrim(Str(first))).Offset(, sdvig + 1).Value = Timer - t
.Calculation = calc_status
.ScreenUpdating = True
End With
End Sub
Вроде все варианты работают, но на небольшом количестве данных. Есть у меня файлик на 30 000 записей:
1. мой код на массиве работает, но чем дальше, тем медленнее - конца не дождался.
2. вариант с формулой зависает неизвестно на каком этапе (но явно небыстро получается), вручную с формулой не пробовал.
3. вариант MaximuS_G не подходит - данные строковые.
Но есть другой путь - сперва отсортировать данные по возрастанию, вручную или макросом, например
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
Sub SortUp()
Application.ScreenUpdating = False
xyz = Selection.Address
Cells.Select
Selection.Sort Key1:=Range(xyz), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:= 1 , MatchCase:=False, Orientation:=xlTopToBottom
Range(xyz).Select
Application.ScreenUpdating = True
End Sub
затем запустить след. код:
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
Sub DelDuplicates()
Dim del As Long
Dim x As Integer
If MsgBox("All Changes Will Be Saved!" & Chr( 13 ) & "Ispected Active Column." & Chr( 13 ) & "Continue?", vbExclamation + vbOKCancel, "Warning!") = vbCancel Then
Exit Sub
End If
WbPth = ActiveWorkbook.Path
WbName = ActiveWorkbook.Name
x = ActiveCell.Column
Application.ScreenUpdating = False
strDate = Format(Now, "yyyy.mm.dd-hh.mm.ss")
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists("c:\Temp\") = False Then MkDir "c:\Temp"
ActiveWorkbook.SaveAs Filename:="c:\Temp\BackupBeforeDelDuplicates." & strDate & "." & ActiveWorkbook.Name, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=True, CreateBackup:=False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=WbPth & "\" & WbName, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = False
With ActiveSheet.UsedRange
For Each cc In .Columns(x).Cells
cikl:
If Cells(cc.Row, x).Value = Cells(cc.Row + 1 , x).Value _
And Cells(cc.Row + 1 , x).Value <> "" Then
Application.StatusBar = " Working on " & cc.Row & " Row" ' визуализация работы
Rows(cc.Row + 1 ).EntireRow.Delete Shift:=xlUp
del = del + 1
'Rows(cc.Row + 1).EntireRow.Hidden = True
GoTo cikl
End If
Next
End With
MsgBox "Ok! Deleted " & del & " Rows!"
Application.StatusBar = False 'сбрасываем визуализацию работы
Application.ScreenUpdating = True
End Sub
В этом примере неуникальные строки удаляются (поэтому там есть cikl: и сперва файл бэкапится), можно переделать под скрытие этих строк
(ну или под пометку, но тогда её положение надо запрашивать в input):
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
With ActiveSheet.UsedRange
For Each cc In .Columns(x).Cells
'cikl:
If Cells(cc.Row, x).Value = Cells(cc.Row + 1 , x).Value _
And Cells(cc.Row + 1 , x).Value <> "" Then
Application.StatusBar = " Working on " & cc.Row & " Row" ' визуализация работы
' Rows(cc.Row + 1).EntireRow.Delete Shift:=xlUp
del = del + 1
Rows(cc.Row + 1 ).EntireRow.Hidden = True
' GoTo cikl
End If
Next
End With
