Страница 2 из 2
Добавлено: 18 янв 2005, 02:21
Naeel Maqsudov
Нет файлов по указанным ссылкам....
Я так и не понял в чем проблема.
Добавлено: 18 янв 2005, 12:55
terminator
Добрый день! :lol:
Я рад что Вы появились, ведь хозяин кода, он всега хозяин!
Новый файл доступен по адресу: webfile.ru/158400 в течение 7 дней до 12:47 25.01.2005.
Да есть такая проблема, не удаляет повторы.
(Кто подскажет где можно размещать файлы белее 14 дней)
Добавлено: 18 янв 2005, 15:35
Игорь Акопян
Меня так просто не обидеть!
При удалении строк нельзя ходить по ним циклом 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
Добавлено: 20 янв 2005, 00:14
Naeel Maqsudov
А по условию задачи сортировку можно/нужно производить?
А то может мой макрос дополить одной строчкой в начала и все
Добавлено: 20 янв 2005, 20:01
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, Вы то без сомнения можете ошибку исправить, осталось совсем ничего, просто исправить. (без сортировки!)
Добавлено: 21 фев 2005, 17:56
Charley
У меня стоит таже задача . Удаление повторяющихся строк ( если во всех колонках есть совпадение , а не в одной ).Попоробывал поставить себе макросы ( листинги которых находятся на этой странички не чего не работает .В чем ошибка понять не могу .Просьба вышлите по почте или выложите файл с работающим файлом (
alerax@inbox.ru)
Добавлено: 21 фев 2005, 23:08
terminator
Перед удалением или обозначением
повторов цветом, необходимо задать
ActiveCell.CurrentRegion
то есть просто выделить первую ячейку
в том столбце к котором Вам необходимо это
Если у Вас всё равно не получается, вышлите мне свой файл.
terminator@ok.ru
Я Вам свой отправил.