Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 03.03.2010, 18:31   #1
vfv
Пользователь
 
Регистрация: 28.07.2009
Сообщений: 54
По умолчанию Удаление одинаковых строк на листе Excel 2003

Прошу отредактировать код макроса для поиска и удаления одинаковых строк на всех листах книги:

Код:
Sub УдалениеДубликатовВКниге()
    Dim sh As Worksheet, coll As New Collection, delra As Range
    On Error Resume Next
    msg = "Поиск дубликатов в книге " & ActiveWorkbook.Name & vbNewLine & vbNewLine
    ДиапазонСравнения = СтолбцыДляОбработки
    Application.ScreenUpdating = False
    For Each sh In ActiveWorkbook.Worksheets
        Set delra = Nothing
        Dim cell As Range, ra As Range
        For Each cell In sh.UsedRange.Rows
            txt = ТекстСтроки(cell, ДиапазонСравнения): Err.Clear
            If Len(txt) Then
                coll.Add txt, txt
                If Err Then If delra Is Nothing Then Set delra = cell Else Set delra = Union(delra, cell)
            End If
        Next cell
        msg = msg & "На листе """ & sh.Name & """" & Space(32 - Len(sh.Name)) & vbTab & "  удалено " & delra.Rows.Count & " строк" & vbNewLine
        delra.EntireRow.Delete    'delra.Interior.ColorIndex = 33
    Next sh
    msg = msg & vbNewLine & "Поиск дубликатов в книге " & ActiveWorkbook.Name & " завершён"
    Application.ScreenUpdating = True
    MsgBox msg, vbInformation, "Готово"
End Sub

Function ТекстСтроки(ByRef ra As Range, ByVal txt As String) As String
    Dim cell As Range
    For Each cell In Intersect(ra.EntireRow, ra.Worksheet.Range(txt))
        ТекстСтроки = ТекстСтроки & Trim(cell)
    Next cell
End Function

Function СтолбцыДляОбработки() As String
    On Error Resume Next: res = "": СтолбцыДляОбработки = "$a:$f"    'Selection.EntireColumn.Address(0, 0)
    msg = "Выберите диапазон, на основании которого будет производиться сравнение строк" & vbNewLine & vbNewLine
    msg = msg & "Не обязательно выделять столбцы целиком - достаточно выделить по одной ячейке в столбцах" & vbNewLine
    'msg = msg & "Для выделения несмежных диапазонов удерживайте клавишу Ctrl" & vbNewLine
    Set A = Application.InputBox(msg, "Выделите сравниваемые столбцы", СтолбцыДляОбработки, , , , , 8)
    res = A.EntireColumn.Address(False, False)
    If res <> "" Then СтолбцыДляОбработки = res Else СтолбцыДляОбработки = "a:f"
End Function
Нужно на основе этого макроса сделать макрос
для поиска и удаления одинаковых строк(оставить только одну) только на одном выбранном листе, столбцы для поиска с 1 по 6 , строки для поиска с 8 до 500 и без MsgBox.Совпадение должно быть точное по всем ячейкам строки .
Файл прикреплён.
Валерий.
Вложения
Тип файла: rar Архив WinRAR.rar (9.5 Кб, 56 просмотров)

Последний раз редактировалось vfv; 03.03.2010 в 22:19.
vfv вне форума Ответить с цитированием
Старый 04.03.2010, 04:59   #2
SAS888
Старожил
 
Аватар для SAS888
 
Регистрация: 05.12.2007
Сообщений: 4,180
По умолчанию

Вам нужен
Цитата:
код макроса для поиска и удаления одинаковых строк на всех листах книги
И в то же время, Вы говорите, что нужно
Цитата:
сделать макрос для поиска и удаления одинаковых строк(оставить только одну) только на одном выбранном листе
Как это понимать? Предположим, что результат нужно поместить на "Лист1" (кстати, кто и каким образом должен это задавать?). Если, например, на листе "Лист2" встречаются одинаковые строки, а на листе "Лист1" такой строки нет, то что нужно сделать? Из "Лист2" удалить дубликаты, и эту строку скопировать на "Лист1"?
Чем шире угол зрения, тем он тупее.
SAS888 вне форума Ответить с цитированием
Старый 04.03.2010, 07:46   #3
vfv
Пользователь
 
Регистрация: 28.07.2009
Сообщений: 54
По умолчанию

Цитата:
Сообщение от SAS888 Посмотреть сообщение
Вам нужен И в то же время, Вы говорите, что нужно Как это понимать? Предположим, что результат нужно поместить на "Лист1" (кстати, кто и каким образом должен это задавать?). Если, например, на листе "Лист2" встречаются одинаковые строки, а на листе "Лист1" такой строки нет, то что нужно сделать? Из "Лист2" удалить дубликаты, и эту строку скопировать на "Лист1"?
Мне нужно ,чтобы макрос на других листах книги не искал одинаковые строки,а искал только на одном выбранном листе и удалял одинаковые строки,оставляя из одинаковых только по одной на этом же листе.
Этот же макрос ищет и удаляет одинаковые по всем листам книги.
vfv вне форума Ответить с цитированием
Старый 04.03.2010, 09:10   #4
SAS888
Старожил
 
Аватар для SAS888
 
Регистрация: 05.12.2007
Сообщений: 4,180
По умолчанию

Для решения подобных задач, лучше не работать непосредственно с ячейками рабочего листа. Это очень долго. Работа с массивами существенно быстрее. Да и перебирать для сравнения можно не каждую ячейку (элемент массива), а целиком строки.
Для примера, предлагаю макрос для удаления повторяющихся строк в выбранном диапазоне для одного (активного) листа:
Код:
Sub Main()
    Dim x As Range, y As New Collection, i As Long, j As Long, k As Long, a(), b(), s As String
    On Error Resume Next: Set x = Application.InputBox("Выделить", "Диапазон сравнения", Type:=8)
    If Err <> 0 Then Exit Sub
    Set x = Intersect(x, ActiveSheet.UsedRange) 'На случай, если выделены столбцы целиком
    a = x.Value: ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)): j = 1
    For i = 1 To UBound(a, 1)
        s = Join(Application.Index(a, i, 0), "|")
        On Error Resume Next: y.Add s, s
        If Err = 0 Then
            For k = 1 To UBound(a, 2): b(j, k) = a(i, k): Next: j = j + 1
        Else: On Error GoTo 0
    End If: Next: x.Value = b
End Sub
Цикл по листам (всем или избранным) "прикрутите" самостоятельно. Если что-то не получится - пишите.
Чем шире угол зрения, тем он тупее.

Последний раз редактировалось SAS888; 04.03.2010 в 09:15.
SAS888 вне форума Ответить с цитированием
Старый 04.03.2010, 09:13   #5
vfv
Пользователь
 
Регистрация: 28.07.2009
Сообщений: 54
По умолчанию

Цитата:
Сообщение от SAS888 Посмотреть сообщение
Для решения подобных задач, лучше не работать непосредственно с ячейками рабочего листа. Это очень долго. Работа с массивами существенно быстрее. Да и перебирать для сравнения можно не каждую ячейку (элемент массива), а целиком строки.
Для примера, предлагаю макрос для удаления повторяющихся строк в выбранном диапазоне для одного (активного) листа:
Код:
Sub Main()
    Dim x As Range, y As New Collection, i As Long, j As Long, k As Long, a(), b(), s As String
    On Error Resume Next: Set x = Application.InputBox("Выделить", "Диапазон сравнения", Type:=8)
    If Err <> 0 Then Exit Sub
    a = x.Value: ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)): j = 1
    For i = 1 To UBound(a, 1)
        s = Join(Application.Index(a, i, 0), "|")
        On Error Resume Next: y.Add s, s
        If Err = 0 Then
            For k = 1 To UBound(a, 2): b(j, k) = a(i, k): Next: j = j + 1
        Else: On Error GoTo 0
    End If: Next: x.Value = b
End Sub
Цикл по листам (всем или избранным) "прикрутите" самостоятельно. Если что-то не получится - пишите.
Спасибо!Сейчас попробую.
vfv вне форума Ответить с цитированием
Старый 04.03.2010, 09:38   #6
vfv
Пользователь
 
Регистрация: 28.07.2009
Сообщений: 54
По умолчанию

Цитата:
Сообщение от vfv Посмотреть сообщение
Спасибо!Сейчас попробую.
Отлично!Этого я и хотел.
Однако надо,чтобы не всплывало окно запроса диа пазона выделения,а диапазон указать конкректно вот этот: A8:E500
vfv вне форума Ответить с цитированием
Старый 04.03.2010, 09:47   #7
SAS888
Старожил
 
Аватар для SAS888
 
Регистрация: 05.12.2007
Сообщений: 4,180
По умолчанию

Код:
надо,чтобы не всплывало окно запроса диапазона выделения, а диапазон указать конкретно вот этот: A8:E500
Ну, так еще проще:
Код:
Sub Main()
    Dim x As Range, y As New Collection, i As Long, j As Long, k As Long, a(), b(), s As String
    Set x = [A8:E500]: a = x.Value: ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)): j = 1
    For i = 1 To UBound(a, 1)
        s = Join(Application.Index(a, i, 0), "|")
        On Error Resume Next: y.Add s, s
        If Err = 0 Then
            For k = 1 To UBound(a, 2): b(j, k) = a(i, k): Next: j = j + 1
        Else: On Error GoTo 0
    End If: Next: x.Value = b
End Sub
Чем шире угол зрения, тем он тупее.
SAS888 вне форума Ответить с цитированием
Старый 04.03.2010, 10:08   #8
vfv
Пользователь
 
Регистрация: 28.07.2009
Сообщений: 54
По умолчанию

Всё работает!
Однако в самом начале я не сказал,что одинаковые строки в одной из ячеек содержат гиперссылку.Она не удаляется,а сдвигается вниз.
Также не удаляется цвет границ от удалённых строк,сдвигается вниз.
Готовлю сейчас файл примера.
vfv вне форума Ответить с цитированием
Старый 04.03.2010, 10:27   #9
vfv
Пользователь
 
Регистрация: 28.07.2009
Сообщений: 54
По умолчанию

Вот,что получается.
Вложения
Тип файла: rar Архив WinRAR.rar (7.0 Кб, 89 просмотров)
vfv вне форума Ответить с цитированием
Старый 04.03.2010, 10:51   #10
SAS888
Старожил
 
Аватар для SAS888
 
Регистрация: 05.12.2007
Сообщений: 4,180
По умолчанию

Посмотрите вложение.
Вложения
Тип файла: rar Удалить одинаковые строки_2.rar (6.4 Кб, 166 просмотров)
Чем шире угол зрения, тем он тупее.
SAS888 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Поиск одинаковых строк Demitriy Microsoft Office Excel 45 26.07.2010 08:50
Перенос строк по двойному клику в Excel 2003 Riddick Помощь студентам 8 15.12.2009 16:59
удаление одинаковых ссылок neoman1 Microsoft Office Word 6 30.11.2009 16:05
удаление одинаковых элементов из массива sauron99 Общие вопросы Delphi 6 15.04.2009 21:27
удаление одинаковых слов (С/С++) jewel Помощь студентам 1 12.12.2008 15:14