Запрет на вставку не оригинального значения ячейки

[Борис_1]

Уважаемые форумчане! Нужна ваша помощь. К сожалению решение проблемы не нашел на форумах (может плохо искал). Имеется файл Excel с обозначениями деталей производителя (первый столбец) и соответствующий им столбец с внутренним обозначением (второй столбец). Имеется еще столбец с некоторыми описаниями и характеристиками. Стоит задача: из других источников (формат excel) вручную копируется в буфер обмена содержимое ячейки с обозначением детали и вставляется в первый или во второй столбец перврого файла с проверкой оригинальности обозначения. Если содержимое вставляется в первый столбец, то необходимо проверить оригинальность обозначения в первом столбце и при совпадении должен быть запрет на вставку. Соответствующая проверка должна быть и по второму столбцу в случае вставки в ячейку второго столбца. Крайне слаб в VB. Пните в сторону примера решения аналогичной проблемы. Буду благодарен.

[kuklp]

Имеется файл Excel...

Не верю. Читаем Правила, выкладываем пример. Иначе тему удалю.

[Борис_1]

Извиняюсь за нарушение правила форума. Выкладываю пример файла куда необходимо вставлять значения в ячейки столбца "B" и "C".

[kuklp]

В модуль листа:

Код Выделить Развернуть

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Rows.Count > 1 Then Exit Sub
    If Intersect(Target, UsedRange, [b:c]) Is Nothing Then Exit Sub
    If Application.CountIf(Intersect(UsedRange, Columns(2)), Target) > 1 Or _
       Application.CountIf(Intersect(UsedRange, Columns(3)), Target) > 1 Then
        Application.EnableEvents = 0
        Cells(Target.Row, 2).Resize(, 3).ClearContents
        MsgBox "Double!"
        Application.EnableEvents = -1
    End If
End Sub

[Борис_1]

Огромное спасибо KuklP! Все работает прекрасно! Не сочтите за наглость, но хотелось бы немного расширить предыдущую задачу: выделяем и копируем в буфер обмена одновременно две ячейки одной строки (например B2 и C2) и затем курсор устанавливаем на свободную строку (в моем примере на ячейку B4) и вставляем информацию из буфера обмена. При этом должна проходить проверка на неидентичность информации по столбцам. Макрос любезно предоставленный KuklP выдает ошибку приведенная во вложении. Как дополнить упомянутый макрос?

[kuklp]

Вы писали:

...вручную копируется в буфер обмена содержимое ячейки с обозначением детали и вставляется в первый или во второй столбец ...

Мой макрос и написан под эти условия. А на скрине вставляется в первый И во второй столбец. Разницу чувствуете?
Попробуйте так:

Код Выделить Развернуть

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Rows.Count > 1 Then Exit Sub
    If Intersect(Target, UsedRange, [b:c]) Is Nothing Then Exit Sub
    Application.EnableEvents = 0
    If Target.Count > 1 Then
        If Application.CountIf(Intersect(UsedRange, Columns(2)), Target(1)) > 1 Or _
           Application.CountIf(Intersect(UsedRange, Columns(3)), Target)(2) > 1 Then _
           GoSub doubles
    Else
        If Application.CountIf(Intersect(UsedRange, Columns(2)), Target(1)) > 1 Then _
           GoSub doubles
    End If
    Application.EnableEvents = -1
    Exit Sub
doubles:
    Cells(Target.Row, 2).Resize(, 3).ClearContents
    MsgBox "Double!"
    Return
End Sub
P.S. и мой Вам совет, не у всех есть 7z, лучше пакуйте в rar. Или не пакуйте. Форум допускает формат gif во вложениях.

[Борис_1]

Спасибо за ответ и наставления KuklP! Макрос работает. Единственный недостаток: при копировании одной ячейки из столбца "С" и вставки в свободную ячейку этого же столбца не происходит проверки на неидентичность. Это я пишу для информации. Логику KuklP я понял и попробую доработать макрос самостоятельно.

[kuklp]

Ну и зачем Вы прикрепляли файл xlsx? В таком формате не может быть макросов. Хотите, чтоб было с макросами, выкладывайте в xls.

Код Выделить Развернуть

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Rows.Count > 1 Then Exit Sub
    If Intersect(Target, UsedRange, [b:c]) Is Nothing Then Exit Sub
    Application.EnableEvents = 0
    If Target.Count > 1 Then
        If Application.CountIf(Intersect(UsedRange, Columns(2)), Target(1)) > 1 Or _
           Application.CountIf(Intersect(UsedRange, Columns(3)), Target)(2) > 1 Then _
           GoSub doubles
    Else
        If Application.CountIf(Intersect(UsedRange, Columns(Target.Column)), Target) > 1 Then _
           GoSub doubles
    End If
    Application.EnableEvents = -1
    Exit Sub
doubles:
    Cells(Target.Row, 2).Resize(, 3).ClearContents
    MsgBox "Double!"
    Return
End Sub

[Борис_1]

Спасибо KuklP! Все прекрасно работает! Вот за что я люблю наш народ: обратишся с просьбой и с начала убедят тебя что ты недоучка, затем буду убеждать, что этого тебе не надо и зате помогут тебе по полной программе! Еще раз мои благодарности и надеюсь это будет интересно не только мне. Отдаю макрос на тестирование народу, т.е. моим молодым коллегам по работе.

[RAN]

Хорошо излагает!... (с) 

[ber_ya]

Доброе  время суток! А как можно выполнить обратную задачу  - запрет на ввод любых значений, кроме заданного для этого столбца?