Шо-шо, то, что кнопка "Удалить дубликаты" появилась только в 2007. Для 2003 можно, например, так (если по-быстрому): где-то в уголке создать сводную таблицу по одному этому нужному полю, забрать оттуда значения и убить сводную
Шо-шо, то, что кнопка "Удалить дубликаты" появилась только в 2007. Для 2003 можно, например, так (если по-быстрому): где-то в уголке создать сводную таблицу по одному этому нужному полю, забрать оттуда значения и убить сводную_Boroda_
ну вот блин :( сделал как-то потупорылому :( [vba]
Код
Sub tghcn_inewth_2003_yf_() Application.ScreenUpdating = 0 '================================================================================================================ 'Sheets(2).Range("$A$1:$A$" & Sheets(1).[C8]).Select Sheets(2).Select Range("$A$1:$A$" & Sheets(1).[C8]).Select '================================================================================================================ Dim iCount As Long, i As Long, j As Long, k As Long Dim Str1 As String, Str2 As String Dim Group As Range k = 1 iCount = Selection.Cells.Count For i = k To iCount Str1 = CStr(Selection.Cells(i).Value) If Str1 <> "" Then For j = i To iCount Str2 = CStr(Selection.Cells(j).Value) If i <> j And Str1 = Str2 Then If Group Is Nothing Then _ Set Group = Selection.Cells(j) Else Set Group = Union(Group, Selection.Cells(j)) End If Next j End If Next i On Error Resume Next Group.Delete Shift:=xlUp '================================================================================================================ Sheets(1).Select End Sub
ну вот блин :( сделал как-то потупорылому :( [vba]
Код
Sub tghcn_inewth_2003_yf_() Application.ScreenUpdating = 0 '================================================================================================================ 'Sheets(2).Range("$A$1:$A$" & Sheets(1).[C8]).Select Sheets(2).Select Range("$A$1:$A$" & Sheets(1).[C8]).Select '================================================================================================================ Dim iCount As Long, i As Long, j As Long, k As Long Dim Str1 As String, Str2 As String Dim Group As Range k = 1 iCount = Selection.Cells.Count For i = k To iCount Str1 = CStr(Selection.Cells(i).Value) If Str1 <> "" Then For j = i To iCount Str2 = CStr(Selection.Cells(j).Value) If i <> j And Str1 = Str2 Then If Group Is Nothing Then _ Set Group = Selection.Cells(j) Else Set Group = Union(Group, Selection.Cells(j)) End If Next j End If Next i On Error Resume Next Group.Delete Shift:=xlUp '================================================================================================================ Sheets(1).Select End Sub
Александр, спс полюбому! :) На будущее пригодится (стырил в мега-копилку) файл уже сбагрил и забыл, блин-блинский опять пришлось 2003 ставить (после гибели материнки думал не понадобится, нет же блин!), а сверху 2013 (шоб умолчания не умалчивались)
[p.s.]Можно как-то в думу закон внести запрещающий использование 2003 Microsoft Office?[/p.s.] [moder]2003 - фигня! Ты что, думаешь, у меня 2000-й чтобы выпендриться стоит? Неее, ко мне обращался гражданин с Excelем таким. Я чуть не упал, как увидел. Сейчас посмотрел - а в подписи-то у меня 2000-го и нет почему-то. Забыл дописать.[/moder] [p.s.]поправка: запретить использование офиса старше 2010 /2007 мне тож не очень :)[/p.s.]
Александр, спс полюбому! :) На будущее пригодится (стырил в мега-копилку) файл уже сбагрил и забыл, блин-блинский опять пришлось 2003 ставить (после гибели материнки думал не понадобится, нет же блин!), а сверху 2013 (шоб умолчания не умалчивались)
[p.s.]Можно как-то в думу закон внести запрещающий использование 2003 Microsoft Office?[/p.s.] [moder]2003 - фигня! Ты что, думаешь, у меня 2000-й чтобы выпендриться стоит? Неее, ко мне обращался гражданин с Excelем таким. Я чуть не упал, как увидел. Сейчас посмотрел - а в подписи-то у меня 2000-го и нет почему-то. Забыл дописать.[/moder] [p.s.]поправка: запретить использование офиса старше 2010 /2007 мне тож не очень :)[/p.s.]Nic70y
ЮMoney 41001841029809
Сообщение отредактировал Nic70y - Пятница, 03.06.2016, 16:38
Немного громоздко получилось, но работает с несколькими столбцами (с расширенным фильтром по методу Сергея у меня не получилось) [vba]
Код
Sub УдалитьДубликаты() Dim rng As Range, dict As Object, i As Long, j As Long, mj As Long, arr(), arr1(), arr2, k As String On Error Resume Next Set rng = Application.InputBox("Выделите диапазон", , , , , , , 8) If rng Is Nothing Then Exit Sub Set dict = CreateObject("Scripting.dictionary") arr = rng.Value mj = UBound(arr, 2) ReDim arr1(0 To mj - 1) For i = 1 To UBound(arr) For j = 1 To mj arr1(j - 1) = arr(i, j) Next k = Join(arr1, "|") If Not dict.exists(k) Then dict.Add Key:=k, Item:=0 Next ReDim arr(1 To dict.Count, 1 To mj) arr1 = dict.keys For i = 1 To UBound(arr) arr2 = Split(arr1(i - 1), "|") For j = 1 To mj arr(i, j) = arr2(j - 1) MsgBox arr(i, j) Next Next Set rng = Application.InputBox("Выделите первую ячейку диапазона, куда будут выведены уникальные значения", , , , , , , 8) If rng Is Nothing Then Exit Sub rng.CurrentRegion.ClearContents rng.Resize(UBound(arr), mj).Value = arr End Sub
[/vba]
Немного громоздко получилось, но работает с несколькими столбцами (с расширенным фильтром по методу Сергея у меня не получилось) [vba]
Код
Sub УдалитьДубликаты() Dim rng As Range, dict As Object, i As Long, j As Long, mj As Long, arr(), arr1(), arr2, k As String On Error Resume Next Set rng = Application.InputBox("Выделите диапазон", , , , , , , 8) If rng Is Nothing Then Exit Sub Set dict = CreateObject("Scripting.dictionary") arr = rng.Value mj = UBound(arr, 2) ReDim arr1(0 To mj - 1) For i = 1 To UBound(arr) For j = 1 To mj arr1(j - 1) = arr(i, j) Next k = Join(arr1, "|") If Not dict.exists(k) Then dict.Add Key:=k, Item:=0 Next ReDim arr(1 To dict.Count, 1 To mj) arr1 = dict.keys For i = 1 To UBound(arr) arr2 = Split(arr1(i - 1), "|") For j = 1 To mj arr(i, j) = arr2(j - 1) MsgBox arr(i, j) Next Next Set rng = Application.InputBox("Выделите первую ячейку диапазона, куда будут выведены уникальные значения", , , , , , , 8) If rng Is Nothing Then Exit Sub rng.CurrentRegion.ClearContents rng.Resize(UBound(arr), mj).Value = arr End Sub
Sub УдалитьДубликаты1() Dim rng As Range, dict As Object, i As Long, j As Long, mj As Long, arr(), arr1(), arr2, k As String On Error Resume Next Set rng = Application.InputBox("Выделите диапазон", , , , , , , 8) If rng Is Nothing Then Exit Sub Set dict = CreateObject("Scripting.dictionary") arr = rng.Value mj = UBound(arr, 2) ReDim arr1(0 To mj - 1) For i = 1 To UBound(arr) For j = 1 To mj arr1(j - 1) = arr(i, j) Next k = Join(arr1, "|") If Not dict.exists(k) Then dict.Add Key:=k, Item:=i Next arr1 = dict.items ReDim arr2(1 To dict.Count, 1 To mj) For i = 1 To UBound(arr2) For j = 1 To mj arr2(i, j) = arr(arr1(i - 1), j) Next Next Set rng = Application.InputBox("Выделите первую ячейку диапазона, куда будут выведены уникальные значения", , , , , , , 8) If rng Is Nothing Then Exit Sub rng.CurrentRegion.ClearContents rng.Resize(UBound(arr2), mj).Value = arr2 End Sub
[/vba]
Мне кажется, так немного проще [vba]
Код
Sub УдалитьДубликаты1() Dim rng As Range, dict As Object, i As Long, j As Long, mj As Long, arr(), arr1(), arr2, k As String On Error Resume Next Set rng = Application.InputBox("Выделите диапазон", , , , , , , 8) If rng Is Nothing Then Exit Sub Set dict = CreateObject("Scripting.dictionary") arr = rng.Value mj = UBound(arr, 2) ReDim arr1(0 To mj - 1) For i = 1 To UBound(arr) For j = 1 To mj arr1(j - 1) = arr(i, j) Next k = Join(arr1, "|") If Not dict.exists(k) Then dict.Add Key:=k, Item:=i Next arr1 = dict.items ReDim arr2(1 To dict.Count, 1 To mj) For i = 1 To UBound(arr2) For j = 1 To mj arr2(i, j) = arr(arr1(i - 1), j) Next Next Set rng = Application.InputBox("Выделите первую ячейку диапазона, куда будут выведены уникальные значения", , , , , , , 8) If rng Is Nothing Then Exit Sub rng.CurrentRegion.ClearContents rng.Resize(UBound(arr2), mj).Value = arr2 End Sub