Страницы: 1
RSS
VBA запрет на добавление дубликата значения
 
Добрый день.
Подскажите пожалуйста по следующему вопросу.
У меня есть макрос который по нажатию на кнопку добавляет строку в заданном диапазоне.
Как с помощью VBA сделать ограничение на добавление повторяющихся значений в диапазоне.

Условный пример во вложении.
В столбце D унникальные значения.
-Макрос должен работать в диапазоне ячеек D2:D14
-При попытке добавления значения, которое уже есть в данном диапазоне - должно выскочить ругательное сообщение какое-нибудь
-и потом удалить это введеное значение
Изменено: vikttur - 08.07.2021 20:53:48
 
не нужно вводить значение, чтобы потом удалять
можно сразу проверить наличие такого значения, написать что ввод дубликатов запрещен и ничего не добавлять
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, ну это понятно...но для омновной задачи не подходит т.к. у меня макрос который добавляет строки по нажатию кнопки и мне необходимо данную проверку на уровне vba сделать
 
Эта задача уже много лет назад была решена Н. Павловым. Вот вариант на VBA, гугл выдал по такому же простому запросу, только дописал "vba"(excel vba запрет ввода повторяющихся данных)
Изменено: DANIKOLA - 08.07.2021 21:28:55
 
а после нажатия кнопки случайно не vba добавляет строки?
вот на этом уровне и внесите поправки в макрос
(а вообще зачем было писать макрос, который добавляет непотребную ерунду в данные? зачем вам понадобился такой бестолковый макрос, который теперь нужно исправлять другим макросом)
решили подкинуть кода на вентилятор?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Уважаемые знатоки,
Хочу немного развить тему.
Оба варианта, предложенные пользователем DANIKOLA  (код VBA и проверка значений от Н.Павлова), работают только в том случае, если вводить данные в  ячейки вручную. Если же вводить с помощью UserForm, то Excel игнорирует эти  условия.
Как можно решить эту задачу?
 
Цитата
Micha Julis написал:
Как можно решить эту задачу?
Цитата
Ігор Гончаренко написал:
сразу проверить наличие такого значения, написать что ввод дубликатов запрещен и ничего не добавлять
По вопросам из тем форума, личку не читаю.
 
Цитата
написал:
Если же вводить с помощью UserForm, то Excel игнорирует эти  условия.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Columns("B:D")) Is Nothing Then
        Exit Sub
    Else
        With Target
            Set Rng = Range(Cells(2, .Column), .Offset(-1))
            If IsError(Application.Match(.Value, Rng, 0)) Then
                Exit Sub
            Else
                MsgBox "Значение уже существует и будет уничтожено"
                Target = Empty
            End If
        End With
    End If
End If
 
testuser   спасибо за желание помочь, но ваш код, к сожалению, не работает. Уже   при первом же вводе в пустой лист код выдает сообщение, что значение уже   существует. Пытался как то преобразовать код, но безрезультатно.

БМВ.   Я понимаю, что лучше не допускать повтора данных, чтоб потом не делать   исправления, но идея такова: Данные через Форму вводит один из   пользователей раз в сутки. При чем пользователи не знают, вводились ли   уже сегодня данные или нет, т.к. не видят страницы Excel. Поэтому   выдается сообщение что данные СЕГОДНЯ уже введены и эта строка не   сохраняется.
 
Micha Julis, небольшая модернизация и все работает )
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Columns("B:D")) Is Nothing Then
        Exit Sub
    Else
        With Target
            If .Row = 1 Or .Row = 2 Then Exit Sub
            Set Rng = Range(Cells(2, .Column), .Offset(-1))
            If IsError(Application.Match(.Value, Rng, 0)) Then
                Exit Sub
            Else
                MsgBox "Error!!!"
                Target = Empty
            End If
        End With
    End If
End Sub

 

testuser cпасибо, но код все равно не работает так как нужно.

Поменял If Intersect(Target, Columns("A:D")) Is Nothing Then на If Intersect(Target, Columns("A:A")) Is Nothing Then

Стало лучше. Но теперь данные в столбцах B:Е не удаляются.

Как можно исправить?

Напомню условие. Только в колонке "А" числа не должны повторятся. Если повторяются, значит вся строка удаляется и выскакивает сообщение "Error!!!"

Спасибо.

 
Вам в #5 подсказали, что нужно делать, а в #7 продублировали...
Для чего продолжать пытаться применить макрос, предназначенный для других задач?
Код
Private Sub CommandButton_Save_Click()

 ' If Me.ComboBox_Name = "" Then MsgBox "Please enter name", vbCritical, "Error": Exit Sub
 ' If Me.ComboBox6 = "" Then MsgBox "Please enter all data", vbCritical, "Error": Exit Sub
 ' If Me.ComboBox7 = "" Then MsgBox "Please enter all data", vbCritical, "Error": Exit Sub
  
   Dim cell As Range: Set cell = [a65000].End(xlUp).Offset(1)
    If Application.CountIf(Columns(1), Me.TextBox_Date) > 0 Then MsgBox "isn't correct", vbCritical, "Error": Exit Sub
   cell(1, 1) = Me.TextBox_Date
   cell(1, 2) = Me.ComboBox_Name
   cell(1, 3) = Me.ComboBox6
   cell(1, 4) = Me.ComboBox7
   cell(1, 5) = Me.ComboBox9
 
End Sub
 
Цитата
написал:
Как можно исправить?
В модуле формы
Код
Public FrmSv As Boolean

Private Sub CommandButton_Save_Click()
    Dim cell As Range: Set cell = [a65000].End(xlUp).Offset(1)    
    Set Rng = Range(Cells(2, 1), cell(1, 1).Offset(-1))

    If IsError(Application.Match(Me.TextBox_Date, Rng, 0)) Then
        FrmSv = True
        cell(1, 1) = Me.TextBox_Date:
        'If cell(1, 1).CountIf(A2, RA) <= 1 Then MsgBox "isn't correct", vbCritical, "Error": Exit Sub
        cell(1, 2) = Me.ComboBox_Name:
        cell(1, 3) = Me.ComboBox6:
        cell(1, 4) = Me.ComboBox7:
        cell(1, 5) = Me.ComboBox9:
        FrmSv = False
    Else
        MsgBox "Error!!!"
        Exit Sub
    End If

 ' If Me.ComboBox_Name = "" Then MsgBox "Please enter name", vbCritical, "Error": Exit Sub
 ' If Me.ComboBox6 = "" Then MsgBox "Please enter all data", vbCritical, "Error": Exit Sub
 ' If Me.ComboBox7 = "" Then MsgBox "Please enter all data", vbCritical, "Error": Exit Sub
End Sub

В модуле листа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Static RmvBl As Boolean
    If RmvBl Then RmvBl = False: Exit Sub
    If UserForm1.FrmSv Then Exit Sub
    
    If Intersect(Target, Columns("A:A")) Is Nothing Then
        Exit Sub
    Else
        With Target
            If .Row = 1 Or .Row = 2 Or IsEmpty(Target) Then Exit Sub
            Set Rng = Range(Cells(2, .Column), .Offset(-1))
            If IsError(Application.Match(.Value, Rng, 0)) Then
                Exit Sub
            Else
                MsgBox "Error!!!"
                RmvBl = True
                Target.Columns("A:E") = Empty
            End If
        End With
    End If
End Sub

Изменено: testuser - 01.10.2022 14:36:36
 
testuser, зачем в данном случае код в модуле листа? Чтобы был? И выполнял бестолковую работу?
Или вы специально учите "плохому"?
 
Цитата
написал: зачем в данном случае код в модуле листа?

Просто учитывал условия вопроса #11.
 
0
Изменено: testuser - 01.10.2022 14:51:48
 
RAN, а куда нужно добавить этот макрос?   Он должен находиться на листе или на форме? Пытаюсь изменить файл, но ничего не получается
 
Все работает. Отлично.
Всем спасибо
Страницы: 1
Наверх