Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1 2 След.
RSS
Запрет внесения повторяющегося слова в столбцах
 
#1
16.08.2015 22:26:25
Всем привет !
Есть макрос, который запрещает ввод повторяющихся слов только по первому столбцу .
Подскажите как дописать его что бы он также запрещая ввод и по другим столбцам, то есть каждый столбец запрет ввода толь в нём а с другими столбцами поиск не пересекается.
И ещё когда вводится дубль, ячейка с оригиналом подкрашивается красным цветом а потом заливка не исчезает. Так вот нужно после ввода другого слова не дубля цвет с оригинала исчез.
Помогите как сделать
Файл прилагаю
Дубли Слов.xls (29.5 КБ)  
 
 
 
#2
16.08.2015 22:41:27
Вкладка Данные - Проверка данных - Тип данных - Другой Формула. Потом выделите смежный диапазон и снова выберите проверку данных и согласитесь с распространением
Код
=СЧЁТЕСЛИ($A$2:A2;A2)<2
Изменено: МВТ - 16.08.2015 22:42:34
 
 
 
#3
16.08.2015 23:03:17
А можно это в макросе как то подправить?
 
 
 
#4
16.08.2015 23:09:09
Условие в примере "растянуто" до 20 строки. Перечитайте, то, что я писал в предыдущем посте
UPD немного формулу подправил и файл перезалил (понятно, почему на соседние колонки не получалось)
Код
=СЧЁТЕСЛИ(A$2:A2;A2)<2
Изменено: МВТ - 16.08.2015 23:22:27
 
 
 
#5
16.08.2015 23:18:30
Я вас понял ещё раз повторил всё получилось. MTB Спасибо!! А в макросе можете подправить код?
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
If Target.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
Dim rFndRng As Range
Set rFndRng = Range("A1:A" & Target.Row - 1).Find(Target, , xlValues, xlWhole)
If rFndRng Is Nothing Then Exit Sub
rFndRng.Interior.Color = vbRed
MsgBox "Есть уже такое слово!" & vbCrLf & "см. ячейку - " & rFndRng.Address(0, 0), vbCritical, "Внимательней!"
End Sub
 
 
 
#6
16.08.2015 23:36:44
А что Вас в нем не устраивает?
 
 
 
#7
17.08.2015 08:04:07
1.Что бы макрос так же распространялся на столбцы( В.С.D)
2. После ввода дубля в столбце А, в  ячейке с оригиналом происходит заливка красным цветом. Нужно что бы после удаления дубля или ввода нового слова не дубля ячейка с оригиналом удаляла заливку
 
 
 
#8
17.08.2015 08:42:47
Grsa, по п.2 используйте условное форматирование.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#9
17.08.2015 11:21:03
Нужен макрос если можно его как то дописать
 
 
 
#10
17.08.2015 11:36:13
Попробуйте такой код:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column > 4 Then Exit Sub
  If Target.Count > 1 Then Exit Sub
  If Target.Value = "" Then Exit Sub
  Dim rFndRng As Range, c As Long
  With Target
    Set rFndRng = Intersect(.Worksheet.UsedRange, .EntireColumn).Cells.Find(Target.Value, Target, xlValues, xlWhole)
  End With
  If rFndRng Is Nothing Then Exit Sub
  If Target.Address = rFndRng.Address Then Exit Sub
  rFndRng.Select
  With rFndRng.Interior
    c = .Color
    .Color = vbRed
    MsgBox "Уже используется в " & rFndRng.Address(0, 0) & vbLf & "Ввод будет отменен", vbCritical, "Внимательней!"
    .Color = c
  End With
  Target.Select
  Application.EnableEvents = False
  Target.ClearContents
  Application.EnableEvents = True
End Sub
Изменено: ZVI - 17.08.2015 11:44:02
 
 
 
#11
17.08.2015 11:46:42
О да ! ZVI огромное спасибо, то что нужно! Вы гуру!
 
 
 
#12
17.07.2017 08:52:49
Подскажите пожалуйста, как изменить этот макрос, чтоб сравнение шло с листом 2?
т.е запрет внесения в Листе 1,слов повторяющихся в листе 2.
Изменено: tanvb - 17.07.2017 13:33:46
 
 
 
#13
12.08.2021 23:53:24
Я давно хотел такой макрос, как в 11 сообщении
Но он работает только на первом листе
Подскажите, пожалуйста, не разбирающемуся человеку, как сделать, чтобы макрос работал на каждом активном листе
Спасибо!
 
 
 
#14
13.08.2021 05:54:33
DAB,
в модуль книги
Код
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
MsgBox "Получилось"
End Sub
 
 
 
#15
13.08.2021 22:35:29
Спасибо большое!!!

И последний вопрос, просто интересно: после срабатывания скрипта вокруг ячейки, значения которой я пытался продублировать, пропадает сетка. Так и должно быть?,
 
 
 
#16
13.08.2021 22:51:26
DAB, я добавил 1 строку кода в макрос от ZVI
макрос - Запрет ввода повторных значений в столбец 2 (В)

Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column > 4 Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    Dim rFndRng As Range, c As Long
    With Target
        Set rFndRng = Intersect(.Worksheet.UsedRange, .EntireColumn).Cells.Find(Target.Value, Target, xlValues, xlWhole)
    End With
    If rFndRng Is Nothing Then Exit Sub
    If Target.Address = rFndRng.Address Then Exit Sub
    rFndRng.Select
    With rFndRng.Interior
        c = .Color
        .Color = vbRed
        MsgBox "Уже используется в " & rFndRng.Address(0, 0) & vbLf & "Ввод будет отменен", vbCritical, "Внимательней!"
        .Color = c
        .Pattern = xlNone '<-- добавил эту строку
    End With
    Target.Select
    Application.EnableEvents = False
    Target.ClearContents
    Application.EnableEvents = True
End Sub
Изменено: New - 13.08.2021 22:51:59
 
 
 
#17
13.08.2021 23:54:55
Спасибо большое, мне этот макрос очень поможет!
Изменено: DAB - 13.08.2021 23:55:37
 
 
 
#18
14.08.2021 00:29:41
Ещё один вопрос появился. Если хочу очистить лист от всей информации, выделяю всё (CTRL+Aׁ). Затем нажимаю DELETE
И появляется такая таблица. Её можно закрыть, конечно. Но должно ли так быть?
 
 
 
#19
14.08.2021 01:02:04
у меня такой проблемы нет
 
 
 
#20
14.08.2021 11:16:07
Срабатывает событие листа Worksheet_SelectionChange.  Ошибку может вызывать  строка с определением количества ячеек,  например
Код
If .Cells.Count > 1 Then

Как избавиться? Не выделять весь лист. Или удалить макрос из модуля листа )
 
 
 
#21
14.08.2021 11:27:43
Цитата
vikttur написал:
Как избавиться?
или написать:
If Target.Cells.CountLarge > 1 Then ...
Изменено: Ігор Гончаренко - 14.08.2021 11:28:54
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#22
14.08.2021 11:39:45
New, выкрасим и выбросим?  :)
Код
.Color = c
.Pattern = xlNone '<-- добавил эту строку
 
 
 
#23
14.08.2021 21:22:33
Зато сетка не пропадает)
P.s. если ячейки не выделены цветом, то это не имеет значения.
 
 
 
#24
18.08.2021 21:52:38
В продолжение темы: обнаружился мешающий побочный эффект макроса.
В расширенных параметрах поиска есть опция: ячейка целиком

Так вот, каждый раз, когда в ячейку столбца А, на который распространяется действие макроса, а также нескольких соседних столбцов (B,C,D) вводишь данные, вышеупомянутая опция поиска становится отмеченной.От этого можно избавиться?
 
 
 
#25
18.08.2021 23:23:36
Цитата
DAB написал:
От этого можно избавиться?
конечно

Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column > 4 Then Exit Sub
    If Target.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    Dim rFndRng As Range, c As Long
    With Target
        Set rFndRng = Intersect(.Worksheet.UsedRange, .EntireColumn).Cells.Find(Target.Value, Target, xlValues, xlWhole)
    End With
    If rFndRng Is Nothing Then Exit Sub
    If Target.Address = rFndRng.Address Then Exit Sub
    rFndRng.Select
    With rFndRng.Interior
        c = .Color
        .Color = vbRed
        MsgBox "Уже используется в " & rFndRng.Address(0, 0) & vbLf & "Ввод будет отменен!", vbCritical, "Внимательней!"
        .Color = c
        .Pattern = xlNone '<-- добавил эту строку
    End With
    Target.Select
    Application.EnableEvents = False
    Target.ClearContents
    Application.EnableEvents = True
    Set rFndRng = Target.Find("", , xlFormulas, xlPart) '<- добавил эту строку
End Sub
Изменено: New - 18.08.2021 23:33:18
 
 
 
#26
19.08.2021 00:04:31
Нет, у меня ничего не изменилось(((
 
 
 
#27
19.08.2021 01:16:17
а должно было! См. файл
Изменено: New - 19.08.2021 01:20:27
 
 
 
#28
19.08.2021 22:14:45
Прежде всего большое спасибо за помощь!
Вы правы, если в Вашем файле ввести к примеру в D8  уже существующее значение - после сообщения макроса галочка не появляется

А если ввести не существующее - она по-прежнему появляется
 
 
 
#29
19.08.2021 22:39:27
А вот так? См. файл
 
 
 
#30
19.08.2021 22:45:11
Идеально!
Огромное спасибо! Очень приятно, что тут всегда можно получить быструю и профессиональную помощь!  :)  
Изменено: DAB - 19.08.2021 22:49:55
 
 
 
Страницы: 1 2 След.
Наверх