Необходима помощь в создании всплывающих подсказок при наведении или нажатии на ячейку. Суть в чем: в файле на Листе1 располагается список сотрудников, на листе2 для некоторых сотрудников прописывается примечание. Необходимо чтобы данное примечание всплывало в качестве подсказки при выделении(а лучше наведении) на строку с именем сотрудника в листе1. Добавлять статичные примечания не вариант, т.к. список на листе1 автоматически обновляется; передача значения ячейке на листе1 тоже не подходит - нужна именно всплывающая подсказка. Соответственно списки могут отличаться как под длине, так и по порядку расположения сотрудников.
Заранее спасибо%)
Доброго времени суток.
Необходима помощь в создании всплывающих подсказок при наведении или нажатии на ячейку. Суть в чем: в файле на Листе1 располагается список сотрудников, на листе2 для некоторых сотрудников прописывается примечание. Необходимо чтобы данное примечание всплывало в качестве подсказки при выделении(а лучше наведении) на строку с именем сотрудника в листе1. Добавлять статичные примечания не вариант, т.к. список на листе1 автоматически обновляется; передача значения ячейке на листе1 тоже не подходит - нужна именно всплывающая подсказка. Соответственно списки могут отличаться как под длине, так и по порядку расположения сотрудников.
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C2:H7")) Is Nothing Then With Target.Validation .Delete DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Not Comment Is Nothing Then .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween '.IgnoreBlank = True '.InCellDropdown = True '.InputTitle = "" .InputMessage = Comment.Offset(, 1) .ShowInput = True .ShowError = False End If End With End If End Sub
[/vba]
Что-то вроде этого в модуле листа [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C2:H7")) Is Nothing Then With Target.Validation .Delete DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Not Comment Is Nothing Then .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween '.IgnoreBlank = True '.InCellDropdown = True '.InputTitle = "" .InputMessage = Comment.Offset(, 1) .ShowInput = True .ShowError = False End If End With End If End Sub
Спасибо, получилось довольно хорошо, если бы не 2 минуса:
1) Как я понимаю командой Target.Validation.Delete происходит удаление проверки данных, наложенных на ячейки 2) Срабатывает за установленным интервалом
Спасибо, получилось довольно хорошо, если бы не 2 минуса:
1) Как я понимаю командой Target.Validation.Delete происходит удаление проверки данных, наложенных на ячейки 2) Срабатывает за установленным интервалом
Подскажите, как с этим быть? Заранее спасибо)Tarquinn
If Not Intersect(Target, Range("C2:H7")) Is Nothing And Target.Count = 1 Then
[/vba]
Если мудрить, то
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set WorkRange = Intersect(Target, Range("C2:H7")) If Not WorkRange Is Nothing Then For Each WorkCell In WorkRange With WorkCell.Validation .Delete 'DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Not Comment Is Nothing Then .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween
'.IgnoreBlank = True '.InCellDropdown = True '.InputTitle = "" .InputMessage = Comment.Offset(, 1) .ShowInput = True .ShowError = False End If End With Next DoEvents End If End Sub
[/vba]
Если по простому то [vba]
Код
If Not Intersect(Target, Range("C2:H7")) Is Nothing And Target.Count = 1 Then
[/vba]
Если мудрить, то
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set WorkRange = Intersect(Target, Range("C2:H7")) If Not WorkRange Is Nothing Then For Each WorkCell In WorkRange With WorkCell.Validation .Delete 'DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Not Comment Is Nothing Then .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ :=xlBetween
'.IgnoreBlank = True '.InCellDropdown = True '.InputTitle = "" .InputMessage = Comment.Offset(, 1) .ShowInput = True .ShowError = False End If End With Next DoEvents End If End Sub
Спасибо за Ваш труд) Осталась последняя проблема (вернее первая)... Стороннюю проверку данных заложенную до введения макроса в рабочем диапазоне, как я понимаю, мы сохранить не сможем?
Спасибо за Ваш труд) Осталась последняя проблема (вернее первая)... Стороннюю проверку данных заложенную до введения макроса в рабочем диапазоне, как я понимаю, мы сохранить не сможем?Tarquinn
Tarquinn, Смотря что там и по какому признаку можно определить что её нужно поменять или подправить. Удалял то я только для того чтоб при отсутствии в таблице с примечаниями удалить все подсказки. Это можно не делать.
Tarquinn, Смотря что там и по какому признаку можно определить что её нужно поменять или подправить. Удалял то я только для того чтоб при отсутствии в таблице с примечаниями удалить все подсказки. Это можно не делать.bmv98rus
Замечательный Временно просто медведь , процентов на 20.
Tarquinn, Смотря что там и по какому признаку можно определить что её нужно поменять или подправить. Удалял то я только для того чтоб при отсутствии в таблице с примечаниями удалить все подсказки. Это можно не делать.
В рабочем диапазоне на ячейках был выпадающий список установленный проверкой данных через имя таблицы со списком.
Tarquinn, Смотря что там и по какому признаку можно определить что её нужно поменять или подправить. Удалял то я только для того чтоб при отсутствии в таблице с примечаниями удалить все подсказки. Это можно не делать.
В рабочем диапазоне на ячейках был выпадающий список установленный проверкой данных через имя таблицы со списком.Tarquinn
Извратил Вашу идею.... Эстетики нуль, но работает. Спасибо)
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set WorkRange = Intersect(Target, Range("C2:C21")) If Not WorkRange Is Nothing Then For Each WorkCell In WorkRange With WorkCell.Validation
'DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Not Comment Is Nothing Then .Modify AlertStyle:=xlValidAlertInformation, Operator _ :=xlBetween
.IgnoreBlank = True .InCellDropdown = True .InputTitle = "УПС" .InputMessage = Comment.Offset(, 1) .ShowInput = True .ShowError = False End If End With Next DoEvents End If
If Not WorkRange Is Nothing Then For Each WorkCell In WorkRange With WorkCell.Validation
'DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Comment Is Nothing Then .Modify AlertStyle:=xlValidAlertInformation, Operator _ :=xlBetween
.IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .InputMessage = "" .ShowInput = False .ShowError = False End If End With Next DoEvents End If
Извратил Вашу идею.... Эстетики нуль, но работает. Спасибо)
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set WorkRange = Intersect(Target, Range("C2:C21")) If Not WorkRange Is Nothing Then For Each WorkCell In WorkRange With WorkCell.Validation
'DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Not Comment Is Nothing Then .Modify AlertStyle:=xlValidAlertInformation, Operator _ :=xlBetween
.IgnoreBlank = True .InCellDropdown = True .InputTitle = "УПС" .InputMessage = Comment.Offset(, 1) .ShowInput = True .ShowError = False End If End With Next DoEvents End If
If Not WorkRange Is Nothing Then For Each WorkCell In WorkRange With WorkCell.Validation
'DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Comment Is Nothing Then .Modify AlertStyle:=xlValidAlertInformation, Operator _ :=xlBetween
.IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .InputMessage = "" .ShowInput = False .ShowError = False End If End With Next DoEvents End If
Могу не смотреть?:-) Если во всех ячейках была проверка данных и надо только подправить коммент, то
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C2:H7")) Is Nothing And Target.Count = 1 Then With Target.Validation '.Delete 'DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Not Comment Is Nothing Then '.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ ':=xlBetween
'.IgnoreBlank = True '.InCellDropdown = True '.InputTitle = "" .InputMessage = Comment.Offset(, 1) '.ShowInput = True '.ShowError = False End If End With End If End Sub
[/vba]
Могу не смотреть?:-) Если во всех ячейках была проверка данных и надо только подправить коммент, то
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C2:H7")) Is Nothing And Target.Count = 1 Then With Target.Validation '.Delete 'DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Not Comment Is Nothing Then '.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ ':=xlBetween
'.IgnoreBlank = True '.InCellDropdown = True '.InputTitle = "" .InputMessage = Comment.Offset(, 1) '.ShowInput = True '.ShowError = False End If End With End If End Sub
Могу не смотреть?:-) Если во всех ячейках была проверка данных и надо только подправить коммент, то
Почему же Обернул условие и добавил вставку пустого примечания при удалении человека из комментариев. Вроде работает)
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C2:H21")) Is Nothing And Target.Count = 1 Then With Target.Validation '.Delete 'DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Comment Is Nothing Then .InputTitle = "" .InputMessage = "" .ShowInput = True Else '.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ ':=xlBetween
.IgnoreBlank = True '.InCellDropdown = True .InputTitle = "Описание" .InputMessage = Comment.Offset(, 1) .ShowInput = True '.ShowError = False End If End With End If End Sub
[/vba]
А не подскажите, какой командой регламентируется положение всплывающей подсказки? А то подсказка при случайном перемещении мышью остается на заданной позиции до перезапуска файла и есть ли операторы способные изменить её визуально (увеличить/изменить шрифт, цвет и т.д.)?
Могу не смотреть?:-) Если во всех ячейках была проверка данных и надо только подправить коммент, то
Почему же Обернул условие и добавил вставку пустого примечания при удалении человека из комментариев. Вроде работает)
[vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Target, Range("C2:H21")) Is Nothing And Target.Count = 1 Then With Target.Validation '.Delete 'DoEvents Set Comment = Sheet1.Columns(2).Find(what:=Cells(Target.Row, 2)) If Comment Is Nothing Then .InputTitle = "" .InputMessage = "" .ShowInput = True Else '.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _ ':=xlBetween
.IgnoreBlank = True '.InCellDropdown = True .InputTitle = "Описание" .InputMessage = Comment.Offset(, 1) .ShowInput = True '.ShowError = False End If End With End If End Sub
[/vba]
А не подскажите, какой командой регламентируется положение всплывающей подсказки? А то подсказка при случайном перемещении мышью остается на заданной позиции до перезапуска файла и есть ли операторы способные изменить её визуально (увеличить/изменить шрифт, цвет и т.д.)?Tarquinn