Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Удалить дубликаты в 2003 - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Удалить дубликаты в 2003 (Макросы/Sub)
Удалить дубликаты в 2003
Nic70y Дата: Пятница, 03.06.2016, 11:09 | Сообщение № 1
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3918
Репутация: 829 ±
Замечаний: 0% ±

Excel 2013
[vba]
Код
    Sheets(2).Range("$A$1:$A$" & Sheets(1).[C8]).RemoveDuplicates Columns:=1, Header:=xlYes
[/vba]вываливается ошибка, чё 2003 злой такой? :)
подскажите тупорылому шо не так :(
з/р спс!


ЯД(poison) 41001841029809
+7 978 049 98 74 (мтс)
 
Ответить
Сообщение[vba]
Код
    Sheets(2).Range("$A$1:$A$" & Sheets(1).[C8]).RemoveDuplicates Columns:=1, Header:=xlYes
[/vba]вываливается ошибка, чё 2003 злой такой? :)
подскажите тупорылому шо не так :(
з/р спс!

Автор - Nic70y
Дата добавления - 03.06.2016 в 11:09
_Boroda_ Дата: Пятница, 03.06.2016, 11:16 | Сообщение № 2
Группа: Модераторы
Ранг: Экселист
Сообщений: 10334
Репутация: 4357 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Шо-шо, то, что кнопка "Удалить дубликаты" появилась только в 2007.
Для 2003 можно, например, так (если по-быстрому): где-то в уголке создать сводную таблицу по одному этому нужному полю, забрать оттуда значения и убить сводную


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеШо-шо, то, что кнопка "Удалить дубликаты" появилась только в 2007.
Для 2003 можно, например, так (если по-быстрому): где-то в уголке создать сводную таблицу по одному этому нужному полю, забрать оттуда значения и убить сводную

Автор - _Boroda_
Дата добавления - 03.06.2016 в 11:16
Nic70y Дата: Пятница, 03.06.2016, 11:34 | Сообщение № 3
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3918
Репутация: 829 ±
Замечаний: 0% ±

Excel 2013
появилась только в 2007
ну вот блин :(
сделал как-то потупорылому :(
[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]
ну чё с Nic70y взять :)


ЯД(poison) 41001841029809
+7 978 049 98 74 (мтс)


Сообщение отредактировал Nic70y - Пятница, 03.06.2016, 11:35
 
Ответить
Сообщение
появилась только в 2007
ну вот блин :(
сделал как-то потупорылому :(
[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]
ну чё с Nic70y взять :)

Автор - Nic70y
Дата добавления - 03.06.2016 в 11:34
Roman777 Дата: Пятница, 03.06.2016, 11:45 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 748
Репутация: 81 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
быстрей и проще словарём будет...)


Много чего не знаю!!!!
 
Ответить
Сообщениебыстрей и проще словарём будет...)

Автор - Roman777
Дата добавления - 03.06.2016 в 11:45
Nic70y Дата: Пятница, 03.06.2016, 11:49 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3918
Репутация: 829 ±
Замечаний: 0% ±

Excel 2013
словарём
не спорю, но мой орфографический 1978г куда-то пропал при переезде :(
[p.s.]Я не стебаюсь, просто вбашник с меня так себе :([/p.s.]


ЯД(poison) 41001841029809
+7 978 049 98 74 (мтс)


Сообщение отредактировал Nic70y - Пятница, 03.06.2016, 11:49
 
Ответить
Сообщение
словарём
не спорю, но мой орфографический 1978г куда-то пропал при переезде :(
[p.s.]Я не стебаюсь, просто вбашник с меня так себе :([/p.s.]

Автор - Nic70y
Дата добавления - 03.06.2016 в 11:49
_Boroda_ Дата: Пятница, 03.06.2016, 16:11 | Сообщение № 6
Группа: Модераторы
Ранг: Экселист
Сообщений: 10334
Репутация: 4357 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Николай, а попробуй вот так
[vba]
Код
Sub tt()
    Dim d_ As Range
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    Set d_ = Selection
    n_ = d_.Cells.Count
    d_.Copy
    Sheets.Add.Range("A2").PasteSpecial Paste:=xlPasteValues
    d_.ClearContents
    Range("A1") = "qqq"
    ActiveSheet.UsedRange
'    Calculate
    On Error Resume Next
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "R1C1:R" & n_ + 1 & "C1").CreatePivotTable TableDestination:="R1C3"
    ActiveSheet.PivotTables(1).PivotFields("qqq").Orientation = xlRowField
    ActiveSheet.PivotTables(1).PivotSelect ("qqq[All]")
        Selection.Copy
    d_(1).PasteSpecial (xlPasteValues)
    ActiveSheet.Delete
    Application.DisplayAlerts = 1
End Sub
[/vba]
Вроде побыстрее работает.
Это как раз
где-то в уголке создать сводную таблицу по одному этому нужному полю, забрать оттуда значения и убить сводную

Кстати, копировать значениями наверное и не нужно. Можно прямо так сводную строить


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеНиколай, а попробуй вот так
[vba]
Код
Sub tt()
    Dim d_ As Range
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    Set d_ = Selection
    n_ = d_.Cells.Count
    d_.Copy
    Sheets.Add.Range("A2").PasteSpecial Paste:=xlPasteValues
    d_.ClearContents
    Range("A1") = "qqq"
    ActiveSheet.UsedRange
'    Calculate
    On Error Resume Next
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "R1C1:R" & n_ + 1 & "C1").CreatePivotTable TableDestination:="R1C3"
    ActiveSheet.PivotTables(1).PivotFields("qqq").Orientation = xlRowField
    ActiveSheet.PivotTables(1).PivotSelect ("qqq[All]")
        Selection.Copy
    d_(1).PasteSpecial (xlPasteValues)
    ActiveSheet.Delete
    Application.DisplayAlerts = 1
End Sub
[/vba]
Вроде побыстрее работает.
Это как раз
где-то в уголке создать сводную таблицу по одному этому нужному полю, забрать оттуда значения и убить сводную

Кстати, копировать значениями наверное и не нужно. Можно прямо так сводную строить

Автор - _Boroda_
Дата добавления - 03.06.2016 в 16:11
Nic70y Дата: Пятница, 03.06.2016, 16:20 | Сообщение № 7
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3918
Репутация: 829 ±
Замечаний: 0% ±

Excel 2013
Александр, спс полюбому! :)
На будущее пригодится (стырил в мега-копилку)
файл уже сбагрил и забыл,
блин-блинский опять пришлось 2003 ставить (после гибели материнки думал не понадобится, нет же блин!),
а сверху 2013 (шоб умолчания не умалчивались)

[p.s.]Можно как-то в думу закон внести запрещающий использование 2003 Microsoft Office?[/p.s.]
[moder]2003 - фигня! Ты что, думаешь, у меня 2000-й чтобы выпендриться стоит? Неее, ко мне обращался гражданин с Excelем таким. Я чуть не упал, как увидел.
Сейчас посмотрел - а в подписи-то у меня 2000-го и нет почему-то. Забыл дописать.[/moder]
[p.s.]поправка: запретить использование офиса старше 2010 /2007 мне тож не очень :)[/p.s.]


ЯД(poison) 41001841029809
+7 978 049 98 74 (мтс)


Сообщение отредактировал Nic70y - Пятница, 03.06.2016, 16:38
 
Ответить
СообщениеАлександр, спс полюбому! :)
На будущее пригодится (стырил в мега-копилку)
файл уже сбагрил и забыл,
блин-блинский опять пришлось 2003 ставить (после гибели материнки думал не понадобится, нет же блин!),
а сверху 2013 (шоб умолчания не умалчивались)

[p.s.]Можно как-то в думу закон внести запрещающий использование 2003 Microsoft Office?[/p.s.]
[moder]2003 - фигня! Ты что, думаешь, у меня 2000-й чтобы выпендриться стоит? Неее, ко мне обращался гражданин с Excelем таким. Я чуть не упал, как увидел.
Сейчас посмотрел - а в подписи-то у меня 2000-го и нет почему-то. Забыл дописать.[/moder]
[p.s.]поправка: запретить использование офиса старше 2010 /2007 мне тож не очень :)[/p.s.]

Автор - Nic70y
Дата добавления - 03.06.2016 в 16:20
KuklP Дата: Пятница, 03.06.2016, 18:36 | Сообщение № 8
Группа: Проверенные
Ранг: Старожил
Сообщений: 2112
Репутация: 453 ±
Замечаний: 0% ±

Ну вы ухари! Из пушки по воробьям :) Как вам вариант одной строкой:
[vba]
Код
Sub www(): Sheets(2).Range("A1:A" & Sheets(1).[C8].value).AdvancedFilter 2, , Range("H1"), -1: End Sub
[/vba]


Ну, с НДС и мы чего-то стoим! kuklp@mail.ru
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеНу вы ухари! Из пушки по воробьям :) Как вам вариант одной строкой:
[vba]
Код
Sub www(): Sheets(2).Range("A1:A" & Sheets(1).[C8].value).AdvancedFilter 2, , Range("H1"), -1: End Sub
[/vba]

Автор - KuklP
Дата добавления - 03.06.2016 в 18:36
Nic70y Дата: Пятница, 03.06.2016, 18:49 | Сообщение № 9
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3918
Репутация: 829 ±
Замечаний: 0% ±

Excel 2013
ну чё, прикольно


ЯД(poison) 41001841029809
+7 978 049 98 74 (мтс)
 
Ответить
Сообщениену чё, прикольно

Автор - Nic70y
Дата добавления - 03.06.2016 в 18:49
МВТ Дата: Пятница, 03.06.2016, 20:13 | Сообщение № 10
Группа: Проверенные
Ранг: Обитатель
Сообщений: 476
Репутация: 136 ±
Замечаний: 0% ±

Excel 2007
Немного громоздко получилось, но работает с несколькими столбцами (с расширенным фильтром по методу Сергея у меня не получилось)
[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
[/vba]

Автор - МВТ
Дата добавления - 03.06.2016 в 20:13
Nic70y Дата: Пятница, 03.06.2016, 20:15 | Сообщение № 11
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3918
Репутация: 829 ±
Замечаний: 0% ±

Excel 2013
Михаил, норм! спс!
Все скопипастю пока дают.


ЯД(poison) 41001841029809
+7 978 049 98 74 (мтс)
 
Ответить
СообщениеМихаил, норм! спс!
Все скопипастю пока дают.

Автор - Nic70y
Дата добавления - 03.06.2016 в 20:15
МВТ Дата: Пятница, 03.06.2016, 20:26 | Сообщение № 12
Группа: Проверенные
Ранг: Обитатель
Сообщений: 476
Репутация: 136 ±
Замечаний: 0% ±

Excel 2007
Мне кажется, так немного проще
[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
[/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
[/vba]

Автор - МВТ
Дата добавления - 03.06.2016 в 20:26
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Удалить дубликаты в 2003 (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2017 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!