макрос на запрет ввода повторяющихся значений

[clar]

Помогите , пожалуйста, составить макрос на запрет ввода повторяющихся значений в диапазоне В10:В20. В строках данного диапазона раскрывающийся список.

[clar]

Где-то ошибка, не могу найти

Код: Выделить всё

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsh As Worksheet
списокЛистов$ = "/Лист1/Лист2/Лист3"
   For Each wsh In ActiveWorkbook.Worksheets
   If InStr(списокЛистов, "/" & wsh.Name & "/") Then
    Dim iSource As Range
      Set iSource = Intersect(Range("B10:B20"), Target)
   ElseIf Not iSource Is Nothing Then

         With Application
         .ScreenUpdating = False
         .DisplayAlerts = False
         .EnableEvents = False
         End With
Dim Trow As Integer
If Target.Count > 1 Then Target.Delete: GoTo Pass
If Target.Value = "" Then GoTo Pass
On Error Resume Next
Trow = Range(Cells(1, 1), Target.Offset(-1, 0)).Find(Target.Value).Row
If Target.Row > 1 Then
If Trow <> 0 Then
If Trow <> Target.Row Then
MsgBox ("значение введено ранее на " & Trow & " строке")
Target.Value = ""
End If
End If
End If
End If
Pass:
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    Next wsh
 End Sub

[clar]

Или макрос (объединенный с сортировкой столбцов) не запускается

Код: Выделить всё

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   Dim iSource As Range
   Select Case Sh.Name
     Case "Лист1", "Лист2", "Лист3"
       Set iSource = Intersect(Range("C10:C20"), Target)
     Case Else
       Exit Sub
   End Select
   If Not iSource Is Nothing Then
   
      Application.EnableEvents = False
      
      Range("B10:C20").Sort _
      Key1:=Range("C10"), Order1:=xlAscending, Header:=xlGuess, _
      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  
     Select Case Sh.Name
     Case "Лист1", "Лист2", "Лист3"
       Set iSource = Intersect(Range("B10:B20"), Target)
     Case Else
       Exit Sub
   End Select
   If Not iSource Is Nothing Then
   
Dim Trow As Integer
If Target.Count > 1 Or Target.Value = "" Then Exit Sub
On Error Resume Next
Trow = Range(Cells(1, 1), Target.Offset(-1, 0)).Find(Target.Value).Row
If Target.Row > 1 Then
If Trow <> 0 Then
If Trow <> Target.Row Then
MsgBox ("значение введено ранее на " & Trow & " строке")
Target.Value = ""

Application.EnableEvents = True

End If
End If
End If
End If
End If
End Sub

[Naeel Maqsudov]

1) Вы пишете: списокЛистов$ = "/Лист1/Лист2/Лист3" а потом занимаетесь парсингом этой строки... Зачем?
Сделайте так

Код: Выделить всё

списокЛистов = array("Лист1","Лист2","Лист3")

Ну и списокЛистов(i) - это очередной лист безо всяких InStr

2) Удаление дубликатов делается так

Код: Выделить всё

Range("$D$4:$D$12").RemoveDuplicates Columns:=1, Header:=xlNo

т.е. всего одной командой
3) Изучите все кнопочки на закладке Данные. Там может найтись еще какое-то количество готовых велосипедов

[clar]

Пробую запустить в таком виде, тоже что-то не идет

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim iSource As Range
Select Case Sh.Name
Case "Лист1", "Лист2", "Лист3"
Set iSource = Intersect(Range("C10:C20"), Target)
Case Else
Exit Sub
End Select
If Not iSource Is Nothing Then
Application.EnableEvents = False
Range("B10:C20").Sort _
Key1:=Range("C10"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("$B$10:$B$20").RemoveDuplicates Columns:=1, Header:=xlNo
Application.EnableEvents = True
End If
End Sub

[pashulka]

От себя добавлю, что если использовать строку, для указания необходимых рабочих листов, то перечень листов необходимо завершить слэшем, т.е. не просто :

Код: Выделить всё

списокЛистов$ = "/Лист1/Лист2/Лист3"

а, как минимум :

Код: Выделить всё

списокЛистов$ = "/Лист1/Лист2/Лист3/"

Кроме того, при таком синтаксисе функции InStr() - будет важен регистр символов, проще говоря, если имя рабочего листа будет не Лист1, а например, ЛИСТ1, то функция вернёт 0 и программные действия в таком листе производиться не будут. Чтобы избежать подобного безобразия, достаточно :

Код: Выделить всё

InStr(1, списокЛистов, "/" & wsh.Name & "/", vbTextCompare)

Впрочем, мы конечно же, можем обойтись и без цикла и без функции InStr() ибо раз мы работаем в MS Excel, то стало быть может использовать и стандартные функции, в т.ч. и =ПОИСКПОЗ()

Пример для модуля листа :

Код: Выделить всё

If Not IsError(Application.Match(Me.Name, Array("Лист1", "Лист2", "Лист3"), 0)) Then
   MsgBox "Лист найден", , ""
Else
   MsgBox "Лист, соответственно, не найден", , ""
End If

Пример для модуля книги :

Код: Выделить всё

If Not IsError(Application.Match(Sh.Name, Array("Лист1", "Лист2", "Лист3"), 0)) Then
   MsgBox "Лист найден", , ""
Else
   MsgBox "Лист, соответственно, не найден", , ""
End If

Что касается удаления повторов, то попробуйте (проверить лично возможности нет, ибо эта возможность появилась только в MS Excel 2007) так :

Код: Выделить всё

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 'Excel 2007 (и старше)
    Select Case LCase(Sh.Name)
        Case "лист1", "лист2", "лист3"
       
        If Not Intersect(Sh.Range("C10:C20"), Target) Is Nothing Then
           Application.EnableEvents = False
          
           Sh.Range("B10:C20").Sort _
           Key1:=Sh.Range("C10"), Order1:=xlAscending, Header:=xlGuess, _
           OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
          
           Sh.Range("B10:B20").RemoveDuplicates Columns:=1, Header:=xlNo
           'странно, что сортируем мы диапазон B10:C20,
           'а удаляем дубликаты только в B10:B20
          
           Application.EnableEvents = True
        End If
    End Select
End Sub

[clar]

В последнем макросе работает сортировка столбцов, но повторы ввести можно (удаляет их только после очередного введения значения в столбец С , но если ввожу новое значение в столбец С в столбце В выпадающие списки на новые значения пропадают (нет возможности их выбрать, только ввести вручную). Нужно чтобы выпадающие списки в диапазоне В10:В20 сохранялись, просто сбрасывалось повторное значение в столбце В.

[pashulka]

...но повторы ввести можно (удаляет их только после очередного введения значения в столбец С...

Именно так всё и задумывалось, смотрите свой собственный пост#5, но ежели такой подход Вам не устраивает, то посмотрите следующий вариант, где повтор ввести/выбрать/скопировать также возможно, но такое действие будет сразу отменено.

Код: Выделить всё

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 'Excel 2000 (и старше)
    Select Case LCase(Sh.Name)
        Case "лист1", "лист2", "лист3"
       
        If Not Intersect(Sh.Range("B10:C20"), Target) Is Nothing Then
           With Application
                .EnableEvents = False
         
                If .Max(.CountIf(Sh.Range("B10:B20"), Target)) > 1 Then
                   .Undo
                Else
                    Sh.Range("B10:C20").Sort _
                    Key1:=Sh.Range("C10"), Order1:=xlAscending, Header:=xlGuess, _
                    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
                End If
         
               .EnableEvents = True
           End With
        End If
    End Select
End Sub

[clar]

Большое спасибо, все работает

[clar]

Подскажите еще,пожалуйста, как указать определенные столбцы в макросе для сортировки.
В таблице нужно отсортировать по столбцу В (в столбце В тоже нужна сортировка) столбцы F, G, I, остальные столбцы C, D , E , H сортируются через функцию ПРОСМОТР. В столбце G нужно, чтобы строки, выбранные из раскрывающегося списка не дублировались.
Пробую сортировку сплошным диапазоном (B18:I37) не получается. Указываю столбцы - тоже.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Select Case LCase(Sh.Name)
Case "лист1", "лист2"

If Not Intersect(Sh.Range("B18:B37, F18:F37, G18:G37, I18:I37"), Target) Is Nothing Then

With Application
.EnableEvents = False

If .Max(.CountIf(Sh.Range("G18:G37"), Target)) > 1 Then
.Undo

Else
Sh.Range("B18:B37,F18:F37, G18:G37, I18:I37").Sort _
Key1:=Sh.Range("B18"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


End If

.EnableEvents = True
End With
End If
End Select
End Sub