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

Я пока смог сделать только так чтобы вторую Аню нельзя было ввести, формулой =СЧЁТЕСЛИ($B:$B;B6)=1 , но это немного не то что мне нужно.
 
Stounv17, Если вы изучите зависимые выпадающие списки, то станет понятно, что просто формулой такое не выполнить. Нужно чтоб список формировался динамически, а при вашей задаче, без макроса не обойтись, даже если он будет из одной строки.
По вопросам из тем форума, личку не читаю.
 
Stounv17,
Добрый вечер!
Скопируйте данный код в модуль листа.
Попробуйте данный макрос, пожалуйста. Из первого столбца я удалил проверку данных.
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Set WorkRange = ActiveSheet.[B5].CurrentRegion
    If Not Intersect(Target, WorkRange.Cells((WorkRange.Cells.Count))) Is Nothing Then
        Set oDic = CreateObject("scripting.dictionary")
        arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 3).Value
        On Error Resume Next
        For i = 1 To UBound(arr)
            oDic.Add CStr(arr(i, 1)) & ";" & CStr(arr(i, 3)), ""
        Next
        If oDic.exists(CStr(Target.Offset(, -2).Value) & ";" & CStr(Target.Value)) Then
            MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
        End If
    End If
End Sub
Изменено: Smurov - 25.08.2019 00:08:00
 
Отличный макрос!!!!!! Спасибо! А можно его как нибудь доработать чтобы допустим Аня написали не с большой буквы а сделали опечатку и написали с маленькой, но Excel дубликат создать не разрешил....???
И еще...., заметил если сделать в имени опечатку, поставить английский, а потом исправить опечатку, то эксель никак не среагирует что в таблице две Ани изучающий Английский. Можно это как-нибудь доработать в макросе???
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    Set WorkRange = ActiveSheet.[B5].CurrentRegion
    If Not Intersect(Target, WorkRange.Cells((WorkRange.Cells.Count))) Is Nothing Then
        Set oDic = CreateObject("scripting.dictionary")
        arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 3).Value
        On Error Resume Next
        For i = 1 To UBound(arr)
            oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 3))), ""
        Next
        If oDic.exists(LCase(CStr(Target.Offset(, -2).Value) & ";" & CStr(Target.Value))) Then
            MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
        End If
    End If
End Sub

Stounv17, добрый день!
Первый вопрос закрыл.
Изменено: Smurov - 25.08.2019 14:28:51
 
[пасибо! Только я что то не могу адаптировать этот макрос для своего листа =(((

Что нужно поменять, чтобы он у меня работал? название столбца типа "Имя" расположен А10, столбец типа "изучаемый язык" расположен D10 (это ячейки названия столбцов) ????

И еще вопрос,если лист должен быть защищен для других столбцов с формулами от шаловливых ручек, и это все выполнялось пойдет такой код:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set WorkRange = ActiveSheet.[B5].CurrentRegion
ActiveSheet.Unprotect Password:=""
Set WorkRange = ActiveSheet.[B5].CurrentRegion    If Not Intersect(Target, WorkRange.Cells((WorkRange.Cells.Count))) Is Nothing Then
        Set oDic = CreateObject("scripting.dictionary")
        arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 3).Value
        On Error Resume Next
        For i = 1 To UBound(arr)
            oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 3))), ""
        Next
        If oDic.exists(LCase(CStr(Target.Offset(, -2).Value) & ";" & CStr(Target.Value))) Then
            MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
        End If
    End If
    ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True, Password:=""
End Sub


К сожалению мои познания в VBA нулевые капец =((((( пожалуйста помоги
Изменено: Stounv17 - 25.08.2019 16:17:25
 
Stounv17, Вы видели, как код выглядит у других? Вот и Вы оформляйте аналогично: ищите такую кнопку (см. скрин) и исправьте своё сообщение.
 
По второму вопросу из поста 4 проверяйте
Код
Dim Language As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    
If Target.Count > 1 Then Exit Sub
Set WorkRange = ActiveSheet.[B5].CurrentRegion
If Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count)) Is Nothing Then
    Language = True
ElseIf Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count - 2)) Is Nothing Then
    Language = False
Else
    Exit Sub
End If
Set oDic = CreateObject("scripting.dictionary")
arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 3).Value
On Error Resume Next
For i = 1 To UBound(arr)
    oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 3))), ""
Next
If Language Then
    If oDic.exists(LCase(CStr(Target.Offset(, -2).Value) & ";" & CStr(Target.Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
Else
    If oDic.exists(LCase(CStr(Target.Value) & ";" & CStr(Target.Offset(, 2).Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
End If

End Sub
Изменено: Smurov - 25.08.2019 15:16:46
 
Цитата
Smurov написал:
По второму вопросу из поста 4 проверяйте
Все работает, КЛАСС!!!! спасибо!!!

Цитата
Smurov написал:
С этим если смогу позже сделаю
Жду.....!=) не думал что адаптировать код с примера для листа куда мне эту всю логику нужно прописать, будет так сложно=(((
 
Stounv17,Адоптировал как понял. Проверяйте.
Для данного кода строки сверху и снизу должны быть пустыми как в файле.

Насчет защиты ни разу не делал.
Надо разобраться.
Если что выложу код.
Код
Dim Language As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    
If Target.Count > 1 Then Exit Sub
Set WorkRange = ActiveSheet.[A10].CurrentRegion
If Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count)) Is Nothing Then
    Language = True
ElseIf Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count - 3)) Is Nothing Then
    Language = False
Else
    Exit Sub
End If
Set oDic = CreateObject("scripting.dictionary")
arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 4).Value
On Error Resume Next
For i = 1 To UBound(arr)
    oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 4))), ""
Next
If Language Then
    If oDic.exists(LCase(CStr(Target.Offset(, -3).Value) & ";" & CStr(Target.Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
Else
    If oDic.exists(LCase(CStr(Target.Value) & ";" & CStr(Target.Offset(, 3).Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
End If
End Sub
 
Изменено: Smurov - 25.08.2019 16:30:21
 
Цитата
Smurov написал: Адоптировал как понял. Проверяйте
что-то не работает. Я Вам сейчас файл в личное сообщение пришлю, посмотрите пожалуйста
 
Пробуйте
Код
Dim Language As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    
If Target.Count > 1 Then Exit Sub
Set WorkRange = ActiveSheet.Range("A10:D" & Cells(Rows.Count, 4).End(xlUp).Row)
If Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count)) Is Nothing Then
    Language = True
ElseIf Not Intersect(Target, WorkRange.Cells(WorkRange.Cells.Count - 3)) Is Nothing Then
    Language = False
Else
    Exit Sub
End If
Set oDic = CreateObject("scripting.dictionary")
arr = WorkRange.Resize(WorkRange.Rows.Count - 1, 4).Value
On Error Resume Next
For i = 1 To UBound(arr)
    oDic.Add LCase(CStr(arr(i, 1))) & ";" & LCase(CStr(arr(i, 4))), ""
Next
If Language Then
    If oDic.exists(LCase(CStr(Target.Offset(, -3).Value) & ";" & CStr(Target.Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
Else
    If oDic.exists(LCase(CStr(Target.Value) & ";" & CStr(Target.Offset(, 3).Value))) Then
        MsgBox "Данный человек уже изучает данный язык": Target.ClearContents
    End If
End If
End Sub
 
Отличный, идеальный код! Большое человеческое спасибо!!!!  ;)

С Уважением, Виктор!
Страницы: 1
Наверх