Прошу прощения за оплошность, допущенную в первый раз. Название темы переименовал. Раздел сменил. (Очень сложно по сайту ориентироваться, впервой в целом). Добрый день всем! Правила прочитал, поиском пользовался, в гугле не забанили. Везде искал - ничего толком не нашел. Возможно (и скорее всего) проблема во мне - и я не понимаю, что смотрю, так как кодами пользоваться не умею. В целом ситуация следующая: нужно написать макрос (код) и именно его, в котором удалялись бы дубликаты. Причем необходимо, чтобы удалялись ранние версии и всегда оставалась более поздняя. Объясню ситуацию: есть большой массив и поставщики в него будут каждый день загружать информацию. В одной колонке номер договора, в другой статус. Статус может соответственно меняться и соответственно всегда более интересен последний. Поэтому нужно чтобы поздняя версия оставалась, а ранняя удалялась. Для этого нужно прикрутить кнопку или автоматом как-то тоже будет работать? Прикладываю примерный файл. Буду безумно признателен! Ах да, я не студент Пересмотрел кучу кодов, но я в них просто не разбираюсь...
По поводу файла - очень долго шел код активации, а гости не могут прикладывать документ. За сим тоже прошу прощения!
Прошу прощения за оплошность, допущенную в первый раз. Название темы переименовал. Раздел сменил. (Очень сложно по сайту ориентироваться, впервой в целом). Добрый день всем! Правила прочитал, поиском пользовался, в гугле не забанили. Везде искал - ничего толком не нашел. Возможно (и скорее всего) проблема во мне - и я не понимаю, что смотрю, так как кодами пользоваться не умею. В целом ситуация следующая: нужно написать макрос (код) и именно его, в котором удалялись бы дубликаты. Причем необходимо, чтобы удалялись ранние версии и всегда оставалась более поздняя. Объясню ситуацию: есть большой массив и поставщики в него будут каждый день загружать информацию. В одной колонке номер договора, в другой статус. Статус может соответственно меняться и соответственно всегда более интересен последний. Поэтому нужно чтобы поздняя версия оставалась, а ранняя удалялась. Для этого нужно прикрутить кнопку или автоматом как-то тоже будет работать? Прикладываю примерный файл. Буду безумно признателен! Ах да, я не студент Пересмотрел кучу кодов, но я в них просто не разбираюсь...
По поводу файла - очень долго шел код активации, а гости не могут прикладывать документ. За сим тоже прошу прощения!Black_Storm
Что-то в вашем примере не стыкуется с вашим пояснением. Если столбец А - номер договора, а столбец D - статус, то совпадений нет. Нет ни одного повторяющегося номера договора с различными статусами. Или номер договора безразличен, а важен только номер статуса. Или я вас не понял!?
Что-то в вашем примере не стыкуется с вашим пояснением. Если столбец А - номер договора, а столбец D - статус, то совпадений нет. Нет ни одного повторяющегося номера договора с различными статусами. Или номер договора безразличен, а важен только номер статуса. Или я вас не понял!?igrtsk
Инструктор по применению лосей в кавалерийских частях РККА
igrtsk, Номер Договора будет как раз в столбце D. До этого дата и прочая не интересная штука. Ах да, возможно в примере не корректно прорисовал ячейки. Нужно чтобы удалялась вся строка... Моя ошибка, признаю.
igrtsk, Номер Договора будет как раз в столбце D. До этого дата и прочая не интересная штука. Ах да, возможно в примере не корректно прорисовал ячейки. Нужно чтобы удалялась вся строка... Моя ошибка, признаю.Black_Storm
Сообщение отредактировал Black_Storm - Понедельник, 03.03.2014, 16:05
Sub ertert() Dim x, i& x = Range("A1:D" & Cells(Rows.Count, 1).End(xlUp).Row).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(x(i, 4)) Then x(.Item(x(i, 4)), 1) = Empty .Item(x(i, 4)) = i Next i End With On Error Resume Next With Range("A1", Cells(Rows.Count, 1).End(xlUp)) .Value = x: .SpecialCells(4).EntireRow.Delete End With End Sub
[/vba]
например, так: [vba]
Код
Sub ertert() Dim x, i& x = Range("A1:D" & Cells(Rows.Count, 1).End(xlUp).Row).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(x(i, 4)) Then x(.Item(x(i, 4)), 1) = Empty .Item(x(i, 4)) = i Next i End With On Error Resume Next With Range("A1", Cells(Rows.Count, 1).End(xlUp)) .Value = x: .SpecialCells(4).EntireRow.Delete End With End Sub
nilem, Огромное спасибо! Работает. Сижу чешу репу, хочу усложнить себе задачу. Возможно додумаюсь сам, но и сюда кину свои мысли: Хочу сделать, чтобы при обнаружении дубликатов выдавалось сообщение в message box и появлялись две кнопки - "Удалить" и "Оставить как есть" соответственно. Ну и далее все понятно - если удалить - удалить и скрыть сообщение с кнопками, если оставить как есть - энд саб и скрытие соответственно.
nilem, Огромное спасибо! Работает. Сижу чешу репу, хочу усложнить себе задачу. Возможно додумаюсь сам, но и сюда кину свои мысли: Хочу сделать, чтобы при обнаружении дубликатов выдавалось сообщение в message box и появлялись две кнопки - "Удалить" и "Оставить как есть" соответственно. Ну и далее все понятно - если удалить - удалить и скрыть сообщение с кнопками, если оставить как есть - энд саб и скрытие соответственно.Black_Storm
Господа, рано я радовался. Не могу понять в чем беда, привязав формулу к необходимому файлу. К сожалению файл не могу приложить В общем ситуация такая. По макросу указанному выше я так понимаю информация берется в диапазоне от А до Д, а в оригинале от A до Z, где А - п/п. Сама таблица начинается с 5 строки. Номер договора по прежнему находится в D. Изменил формулу следующим образом: [vba]
Код
Private Sub CommandButton1_Click() Dim x, i& x = Range("B5:Z" & Cells(Rows.Count, 1).End(xlUp).Row).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(x(i, 4)) Then x(.Item(x(i, 4)), 1) = Empty .Item(x(i, 4)) = i Next i End With On Error Resume Next With Range("B5", Cells(Rows.Count, 1).End(xlUp)) .Value = x: .SpecialCells(4).EntireRow.Delete End With End Sub
[/vba] Не могу понять почему при клике удаляется вся информация...
Строк может быть бесконечное множество в документе... Буду признателен!
Господа, рано я радовался. Не могу понять в чем беда, привязав формулу к необходимому файлу. К сожалению файл не могу приложить В общем ситуация такая. По макросу указанному выше я так понимаю информация берется в диапазоне от А до Д, а в оригинале от A до Z, где А - п/п. Сама таблица начинается с 5 строки. Номер договора по прежнему находится в D. Изменил формулу следующим образом: [vba]
Код
Private Sub CommandButton1_Click() Dim x, i& x = Range("B5:Z" & Cells(Rows.Count, 1).End(xlUp).Row).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(x(i, 4)) Then x(.Item(x(i, 4)), 1) = Empty .Item(x(i, 4)) = i Next i End With On Error Resume Next With Range("B5", Cells(Rows.Count, 1).End(xlUp)) .Value = x: .SpecialCells(4).EntireRow.Delete End With End Sub
[/vba] Не могу понять почему при клике удаляется вся информация...
Строк может быть бесконечное множество в документе... Буду признателен!Black_Storm
Сообщение отредактировал Black_Storm - Вторник, 04.03.2014, 12:10
nilem, Приложу целый файл. В общем и целом по уже нормальному файлу - когда будет вбиваться две одинаковых строки с номером договора хочется оставить только последний нормальный. Ни с каким другим столбцом сравнивать необходимости нет. Повторяется - предыдущая не нужна. Как-то так. Огромное Вам спасибо!
nilem, Приложу целый файл. В общем и целом по уже нормальному файлу - когда будет вбиваться две одинаковых строки с номером договора хочется оставить только последний нормальный. Ни с каким другим столбцом сравнивать необходимости нет. Повторяется - предыдущая не нужна. Как-то так. Огромное Вам спасибо!Black_Storm
Sub ertert() Dim x, i& With Range("D4", Cells(Rows.Count, 4).End(xlUp)) x = .Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(x(i, 1)) Then x(.Item(x(i, 1)), 1) = Empty .Item(x(i, 1)) = i Next i End With .Value = x On Error Resume Next If MsgBox("Удалить повторы?", 36) = vbYes Then .SpecialCells(4).EntireRow.Delete End With End Sub
[/vba]
вот так попробуйте: [vba]
Код
Sub ertert() Dim x, i& With Range("D4", Cells(Rows.Count, 4).End(xlUp)) x = .Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(x(i, 1)) Then x(.Item(x(i, 1)), 1) = Empty .Item(x(i, 1)) = i Next i End With .Value = x On Error Resume Next If MsgBox("Удалить повторы?", 36) = vbYes Then .SpecialCells(4).EntireRow.Delete End With End Sub
nilem, Не удаляет дубликаты на данный момент. Если мсгбокс сложно реализовать - не нужно. Это, так сказать, фетиш. Вы мне очень сильно помогаете! Безумно признателен!
Уже начинаю понимать этот язык) вроде мсгбокс реализовать вообще не сложно. Не могу понять почему не ищет дубликаты по Вашему коду...
nilem, Не удаляет дубликаты на данный момент. Если мсгбокс сложно реализовать - не нужно. Это, так сказать, фетиш. Вы мне очень сильно помогаете! Безумно признателен!
Уже начинаю понимать этот язык) вроде мсгбокс реализовать вообще не сложно. Не могу понять почему не ищет дубликаты по Вашему коду...Black_Storm
Сообщение отредактировал Black_Storm - Вторник, 04.03.2014, 13:20
Если номера договоров - просто числа, то нужно подправить словарь. А если договоры как обычно (что-то вроде "СР25-456/45-2014"), то должно работать.
попробуйте еще раз в файле
Если номера договоров - просто числа, то нужно подправить словарь. А если договоры как обычно (что-то вроде "СР25-456/45-2014"), то должно работать.nilem
Private Sub CommandButton1_Click() Dim x, i& With Range("D5", Cells(Rows.Count, 5).End(xlUp)) x = .Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(x(i, 1)) Then x(.Item(x(i, 1)), 1) = Empty .Item(x(i, 1)) = i Next i End With On Error Resume Next If MsgBox("Удалить повторы?", 36) = vbYes Then .Value = x: .SpecialCells(5).EntireRow.Delete End With End Sub
[/vba]
Мне кажется ошибка в [vba]
Код
With Range("D5", Cells(Rows.Count, 4).End(xlUp))
[/vba] этой строке... Но я особо не разбираюсь во всем этом...(
[vba]
Код
Private Sub CommandButton1_Click() Dim x, i& With Range("D5", Cells(Rows.Count, 5).End(xlUp)) x = .Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(x(i, 1)) Then x(.Item(x(i, 1)), 1) = Empty .Item(x(i, 1)) = i Next i End With On Error Resume Next If MsgBox("Удалить повторы?", 36) = vbYes Then .Value = x: .SpecialCells(5).EntireRow.Delete End With End Sub
[/vba]
Мне кажется ошибка в [vba]
Код
With Range("D5", Cells(Rows.Count, 4).End(xlUp))
[/vba] этой строке... Но я особо не разбираюсь во всем этом...(Black_Storm
Сообщение отредактировал Serge_007 - Вторник, 04.03.2014, 22:51
Sub ertert() Dim x, i& With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With With ActiveSheet If .FilterMode Then .ShowAllData x = .Range("E3", .Cells(Rows.Count, 5).End(xlUp)).Value End With With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(CStr(x(i, 1))) Then x(.Item(CStr(x(i, 1))), 1) = Empty .Item(CStr(x(i, 1))) = i Next i End With On Error Resume Next If MsgBox("Óäàëèòü ïîâòîðû?", 36) = vbYes Then With Range("E3", Cells(Rows.Count, 5).End(xlUp)) .Value = x .SpecialCells(4).EntireRow.Delete .Offset(1, -4).Value = Evaluate("=row(" & .Address & ")-2") End With End If With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub
[/vba]
вот такой получился код: [vba]
Код
Sub ertert() Dim x, i& With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With With ActiveSheet If .FilterMode Then .ShowAllData x = .Range("E3", .Cells(Rows.Count, 5).End(xlUp)).Value End With With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(CStr(x(i, 1))) Then x(.Item(CStr(x(i, 1))), 1) = Empty .Item(CStr(x(i, 1))) = i Next i End With On Error Resume Next If MsgBox("Óäàëèòü ïîâòîðû?", 36) = vbYes Then With Range("E3", Cells(Rows.Count, 5).End(xlUp)) .Value = x .SpecialCells(4).EntireRow.Delete .Offset(1, -4).Value = Evaluate("=row(" & .Address & ")-2") End With End If With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub
Еще раз всем привет! В коде выше все начинается с третьей строки, в моем файле с 5-ой. Изменил значение Е3 на Е5 везде и строку .Offset(1, -4).Value = Evaluate("=row(" & .Address & ")-2") на .Offset(1, -4).Value = Evaluate("=row(" & .Address & ")-4") Однако, нумерация в первой колонке начинается теперь с 4. Вместо -4 перепробовал все значение от 0 до -6 - результата нуль Логикой понимаю, что с -4 должно работать, на практике не пониманию почему не работает...
Еще раз всем привет! В коде выше все начинается с третьей строки, в моем файле с 5-ой. Изменил значение Е3 на Е5 везде и строку .Offset(1, -4).Value = Evaluate("=row(" & .Address & ")-2") на .Offset(1, -4).Value = Evaluate("=row(" & .Address & ")-4") Однако, нумерация в первой колонке начинается теперь с 4. Вместо -4 перепробовал все значение от 0 до -6 - результата нуль Логикой понимаю, что с -4 должно работать, на практике не пониманию почему не работает...Black_Storm
наверное, что-то пропустили. Вот полный код для случая, если начало в 5-й строке (5-я строка - заголовки) [vba]
Код
Sub ertert() Dim x, i& With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With With ActiveSheet If .FilterMode Then .ShowAllData x = .Range("E5", .Cells(Rows.Count, 5).End(xlUp)).Value End With With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(CStr(x(i, 1))) Then x(.Item(CStr(x(i, 1))), 1) = Empty .Item(CStr(x(i, 1))) = i Next i End With On Error Resume Next If MsgBox("Удалить повторы?", 36) = vbYes Then With Range("E5", Cells(Rows.Count, 5).End(xlUp)) .Value = x .SpecialCells(4).EntireRow.Delete .Offset(1, -4).Value = Evaluate("=row(" & .Address & ")-4") End With End If With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub
[/vba]
наверное, что-то пропустили. Вот полный код для случая, если начало в 5-й строке (5-я строка - заголовки) [vba]
Код
Sub ertert() Dim x, i& With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With With ActiveSheet If .FilterMode Then .ShowAllData x = .Range("E5", .Cells(Rows.Count, 5).End(xlUp)).Value End With With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 1 To UBound(x) If .Exists(CStr(x(i, 1))) Then x(.Item(CStr(x(i, 1))), 1) = Empty .Item(CStr(x(i, 1))) = i Next i End With On Error Resume Next If MsgBox("Удалить повторы?", 36) = vbYes Then With Range("E5", Cells(Rows.Count, 5).End(xlUp)) .Value = x .SpecialCells(4).EntireRow.Delete .Offset(1, -4).Value = Evaluate("=row(" & .Address & ")-4") End With End If With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
Пересмотрел кучу кодов, но я в них просто не разбираюсь... 
