Удаление одинаковых данных в Экселе

[Naeel Maqsudov]

Нет файлов по указанным ссылкам....
Я так и не понял в чем проблема.

[terminator]

Добрый день! :lol:
Я рад что Вы появились, ведь хозяин кода, он всега хозяин!

Новый файл доступен по адресу: webfile.ru/158400 в течение 7 дней до 12:47 25.01.2005.

Да есть такая проблема, не удаляет повторы.

(Кто подскажет где можно размещать файлы белее 14 дней)

[Игорь Акопян]

Меня так просто не обидеть!
При удалении строк нельзя ходить по ним циклом for... Исправил

Код: Выделить всё

Private Sub CommandButton2_Click()

Dim sh As Range, r As Range, ColCnt As Integer, I As Integer, J As Integer, diff_cnt As Integer
Dim IM As Integer
  Set sh = ActiveCell.CurrentRegion
  ColCnt = sh.Columns.Count
  IM = 1:
  Do
    I = IM + 1
    Do
      diff_cnt = 0
      For J = 1 To ColCnt
        If sh.Cells(IM, J).Value <> sh.Cells(I, J).Value Then diff_cnt = diff_cnt + 1
        If diff_cnt > 1 Then Exit For
      Next
      If diff_cnt = 0 Then
        sh.Rows(I).Delete xlUp
      Else
        If diff_cnt = 1 Then sh.Rows(I).Interior.ColorIndex = 8
        I = I + 1
      End If
    Loop Until I > sh.Rows.Count
    IM = IM + 1
  Loop Until IM > sh.Rows.Count - 1

End Sub

[Naeel Maqsudov]

А по условию задачи сортировку можно/нужно производить?
А то может мой макрос дополить одной строчкой в начала и все

[terminator]

Ну наверно, в силу того что при дополнительной сортировке данные перемещаются, хотелось бы увидеть вариант при котором, всё таки сортировки не происходит, но повторы удаляются.
По удалению при сортировке коды есть:
Вариант 1

Columns("A:A").Select
Selection.Sort Key1:=Range("A1")
x = 1
y = 2
While I <= ActiveCell.CurrentRegion.Rows.Count
If Cells(x, 1) = Cells(y, 1) Then
Cells(y, 1).EntireRow.Delete
Else
x = x + 1
y = y + 1
End If
Wend

Вариант 2

Application.ScreenUpdating = False
Set objTable = Cells(1, 1).CurrentRegion
lngRow = 1
lngFirstRow = lngRow
With objTable
.Columns(1).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, Orientation:=xlTopToBottom
Do Until lngRow > .Rows.Count
Do While .Cells(lngRow, 1) = .Cells(lngRow + 1, 1)
lngRow = lngRow + 1
Loop
If lngFirstRow < lngRow Then .Rows(lngFirstRow + 1 & ":" & lngRow).Rows.Delete Shift:=xlUp
lngFirstRow = lngFirstRow + 1
lngRow = lngFirstRow
Loop
End With

Может быть изменить вот этот, чтоб охватывал не только столбец,
но и строки. Он сортировку не производит.

Вариант 3

k = Application.WorksheetFunction.CountA(Columns(1))
Set tR = Range(Cells(1, 1), Cells(k, 1))
m = tR.Rows.Count
For I = 1 To m
If Application.WorksheetFunction.CountIf(tR, Cells(I, 1)) > 1 Then
tR.Rows(I).Delete
I = 1
m = m - 1
End If
Next

Все продемонстрированные коды проверены и работают, но
автором являюсь не я, иначе бы здесь не тёрся в поисках, а писал бы сам.
> Игорю Акопяну > У достойного мужчины, всегда есть достойный ответ. :lol: Всё супер!

Naeel Maqsudov, Вы то без сомнения можете ошибку исправить, осталось совсем ничего, просто исправить. (без сортировки!)

[Charley]

У меня стоит таже задача . Удаление повторяющихся строк ( если во всех колонках есть совпадение , а не в одной ).Попоробывал поставить себе макросы ( листинги которых находятся на этой странички не чего не работает .В чем ошибка понять не могу .Просьба вышлите по почте или выложите файл с работающим файлом (alerax@inbox.ru)

[terminator]

Перед удалением или обозначением
повторов цветом, необходимо задать
ActiveCell.CurrentRegion
то есть просто выделить первую ячейку
в том столбце к котором Вам необходимо это
Если у Вас всё равно не получается, вышлите мне свой файл.
terminator@ok.ru
Я Вам свой отправил.