Удаление одинаковых строк на листе Excel 2003

[vfv]

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

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.Совпадение должно быть точное по всем ячейкам строки .
Файл прикреплён.
Валерий.

[SAS888]

Вам нужен

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

И в то же время, Вы говорите, что нужно

сделать макрос для поиска и удаления одинаковых строк(оставить только одну) только на одном выбранном листе

Как это понимать? Предположим, что результат нужно поместить на "Лист1" (кстати, кто и каким образом должен это задавать?). Если, например, на листе "Лист2" встречаются одинаковые строки, а на листе "Лист1" такой строки нет, то что нужно сделать? Из "Лист2" удалить дубликаты, и эту строку скопировать на "Лист1"?

[vfv]

Сообщение от SAS888

Вам нужен И в то же время, Вы говорите, что нужно Как это понимать? Предположим, что результат нужно поместить на "Лист1" (кстати, кто и каким образом должен это задавать?). Если, например, на листе "Лист2" встречаются одинаковые строки, а на листе "Лист1" такой строки нет, то что нужно сделать? Из "Лист2" удалить дубликаты, и эту строку скопировать на "Лист1"?

Мне нужно ,чтобы макрос на других листах книги не искал одинаковые строки,а искал только на одном выбранном листе и удалял одинаковые строки,оставляя из одинаковых только по одной на этом же листе.
Этот же макрос ищет и удаляет одинаковые по всем листам книги.

[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
    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

Цикл по листам (всем или избранным) "прикрутите" самостоятельно. Если что-то не получится - пишите.

[vfv]

Сообщение от 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]

Сообщение от vfv

Спасибо!Сейчас попробую.

Отлично!Этого я и хотел.
Однако надо,чтобы не всплывало окно запроса диа пазона выделения,а диапазон указать конкректно вот этот: A8:E500

[SAS888]

надо,чтобы не всплывало окно запроса диапазона выделения, а диапазон указать конкретно вот этот: 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

[vfv]

Всё работает!
Однако в самом начале я не сказал,что одинаковые строки в одной из ячеек содержат гиперссылку.Она не удаляется,а сдвигается вниз.
Также не удаляется цвет границ от удалённых строк,сдвигается вниз.
Готовлю сейчас файл примера.

[vfv]

Вот,что получается.

[SAS888]

Посмотрите вложение.