Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Всплывающая подсказка - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Всплывающая подсказка (Макросы/Sub)
Всплывающая подсказка
ekut Дата: Пятница, 01.01.2021, 17:57 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 123
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Уважаемые программисты, помогите поставить подсказку в лист Алмакаев (и Шаблон) в верхний левый угол. Все данные в Нормах (подсказка как во втором файле). Но подсказку нужно сделать так, чтобы при изменении фамилии подсказка менялась согласно фамилии.
К сообщению приложен файл: 8975765.xls(135.0 Kb) · 7280142.xlsm(42.9 Kb)
 
Ответить
СообщениеУважаемые программисты, помогите поставить подсказку в лист Алмакаев (и Шаблон) в верхний левый угол. Все данные в Нормах (подсказка как во втором файле). Но подсказку нужно сделать так, чтобы при изменении фамилии подсказка менялась согласно фамилии.

Автор - ekut
Дата добавления - 01.01.2021 в 17:57
Kuzmich Дата: Суббота, 02.01.2021, 21:50 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 575
Репутация: 113 ±
Замечаний: 0% ±

Excel 2003
Цитата
поставить подсказку в лист Алмакаев

'ActiveSheet.Pictures.Paste(Link:=True).Select не работает с умной таблицей
Преобразовал таблицу в диапазон
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
      If Not Intersect(Target, Range("A1")) Is Nothing Then
         Application.CutCopyMode = False
                 Application.EnableEvents = False
        Application.ScreenUpdating = False
        If ActiveSheet.Pictures.Count > 0 Then Shapes("PopapTab").Delete

'ищем границы диапазона для определенной фамилии в А1
Dim i As Long
Dim j As Long
Dim FoundFIO As Range
  Set FoundFIO = Sheets("Нормы").Columns("B:C").Find(Target, , xlValues, xlWhole)
    If Not FoundFIO Is Nothing Then
      j = FoundFIO.Row
      i = j
      Do
        i = i - 1
      Loop While Sheets("Нормы").Cells(i, "A").Borders(xlEdgeTop).Weight <> xlMedium
    Else
       MsgBox "На листе 'Нормы' нет фамилии: " & Target
    End If
    
    Sheets("Нормы").Range("A" & i & ":C" & j).Copy
    
    Sheets(Target.Parent.Name).Select
    ActiveSheet.Pictures.Paste(Link:=True).Select
    Application.CutCopyMode = False
    Selection.Name = "PopapTab"
    Top = Target.Top - Selection.Height
    If Top < 0 Then Top = Target.Top + Target.Height
    Selection.Top = Top
    Selection.Left = Target.Left + Target.Width / 2
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
  '      .ForeColor.ObjectThemeColor = msoThemeColorAccent1
        .ForeColor.TintAndShade = 0
'        .ForeColor.Brightness = 0.400000006
        .Transparency = 0
        .Solid
    End With
    With Selection.ShapeRange.Shadow
'        .Type = msoShadow21
        .Visible = msoTrue
'        .Style = msoShadowStyleOuterShadow
'        .Blur = 4
        .OffsetX = 4.9497474683
        .OffsetY = 4.9497474683
'        .RotateWithShape = msoFalse
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0.599999994
'        .Size = 100
    End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True
'     Target.Select
     Cancel = True
    Else
        On Error Resume Next
        ActiveSheet.Shapes("PopapTab").Delete
    End If
End Sub
[/vba]
 
Ответить
Сообщение
Цитата
поставить подсказку в лист Алмакаев

'ActiveSheet.Pictures.Paste(Link:=True).Select не работает с умной таблицей
Преобразовал таблицу в диапазон
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
      If Not Intersect(Target, Range("A1")) Is Nothing Then
         Application.CutCopyMode = False
                 Application.EnableEvents = False
        Application.ScreenUpdating = False
        If ActiveSheet.Pictures.Count > 0 Then Shapes("PopapTab").Delete

'ищем границы диапазона для определенной фамилии в А1
Dim i As Long
Dim j As Long
Dim FoundFIO As Range
  Set FoundFIO = Sheets("Нормы").Columns("B:C").Find(Target, , xlValues, xlWhole)
    If Not FoundFIO Is Nothing Then
      j = FoundFIO.Row
      i = j
      Do
        i = i - 1
      Loop While Sheets("Нормы").Cells(i, "A").Borders(xlEdgeTop).Weight <> xlMedium
    Else
       MsgBox "На листе 'Нормы' нет фамилии: " & Target
    End If
    
    Sheets("Нормы").Range("A" & i & ":C" & j).Copy
    
    Sheets(Target.Parent.Name).Select
    ActiveSheet.Pictures.Paste(Link:=True).Select
    Application.CutCopyMode = False
    Selection.Name = "PopapTab"
    Top = Target.Top - Selection.Height
    If Top < 0 Then Top = Target.Top + Target.Height
    Selection.Top = Top
    Selection.Left = Target.Left + Target.Width / 2
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
  '      .ForeColor.ObjectThemeColor = msoThemeColorAccent1
        .ForeColor.TintAndShade = 0
'        .ForeColor.Brightness = 0.400000006
        .Transparency = 0
        .Solid
    End With
    With Selection.ShapeRange.Shadow
'        .Type = msoShadow21
        .Visible = msoTrue
'        .Style = msoShadowStyleOuterShadow
'        .Blur = 4
        .OffsetX = 4.9497474683
        .OffsetY = 4.9497474683
'        .RotateWithShape = msoFalse
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0.599999994
'        .Size = 100
    End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True
'     Target.Select
     Cancel = True
    Else
        On Error Resume Next
        ActiveSheet.Shapes("PopapTab").Delete
    End If
End Sub
[/vba]

Автор - Kuzmich
Дата добавления - 02.01.2021 в 21:50
ekut Дата: Воскресенье, 03.01.2021, 09:09 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 123
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Kuzmich, здравствуйте! Спасибо большое! Вроде все работает, нооооо так глючит подсказка. Если нетрудно, гляньте!!!!!
К сообщению приложен файл: 1111111.xlsm(75.1 Kb)
 
Ответить
СообщениеKuzmich, здравствуйте! Спасибо большое! Вроде все работает, нооооо так глючит подсказка. Если нетрудно, гляньте!!!!!

Автор - ekut
Дата добавления - 03.01.2021 в 09:09
Kuzmich Дата: Воскресенье, 03.01.2021, 09:50 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 575
Репутация: 113 ±
Замечаний: 0% ±

Excel 2003
ekut
Я в коде закомментировал некоторые строки для версии Excel2003.
Раскомментируйте и проверьте работу всплывающей подсказки
 
Ответить
Сообщениеekut
Я в коде закомментировал некоторые строки для версии Excel2003.
Раскомментируйте и проверьте работу всплывающей подсказки

Автор - Kuzmich
Дата добавления - 03.01.2021 в 09:50
ekut Дата: Воскресенье, 03.01.2021, 10:08 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 123
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Да вроде все раскомментировала, открывается не сразу и скрывается тяжело. По несколько раз приходиться кликать


Сообщение отредактировал ekut - Воскресенье, 03.01.2021, 10:09
 
Ответить
СообщениеДа вроде все раскомментировала, открывается не сразу и скрывается тяжело. По несколько раз приходиться кликать

Автор - ekut
Дата добавления - 03.01.2021 в 10:08
Kuzmich Дата: Воскресенье, 03.01.2021, 10:36 | Сообщение № 6
Группа: Проверенные
Ранг: Ветеран
Сообщений: 575
Репутация: 113 ±
Замечаний: 0% ±

Excel 2003
Цитата
скрывается тяжело

Макрос срабатывает на изменение фамилии в ячейке А1, при этом происходит
замена всплывающей подсказки. Если надо ее убрать, то можно просто вырезать.
 
Ответить
Сообщение
Цитата
скрывается тяжело

Макрос срабатывает на изменение фамилии в ячейке А1, при этом происходит
замена всплывающей подсказки. Если надо ее убрать, то можно просто вырезать.

Автор - Kuzmich
Дата добавления - 03.01.2021 в 10:36
ekut Дата: Воскресенье, 03.01.2021, 11:01 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 123
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Ок, спасибо огромное!!!! Я так поняла подсказка больше никак быстрее работать не будет. Других вариантов нет?
 
Ответить
СообщениеОк, спасибо огромное!!!! Я так поняла подсказка больше никак быстрее работать не будет. Других вариантов нет?

Автор - ekut
Дата добавления - 03.01.2021 в 11:01
Kuzmich Дата: Воскресенье, 03.01.2021, 11:19 | Сообщение № 8
Группа: Проверенные
Ранг: Ветеран
Сообщений: 575
Репутация: 113 ±
Замечаний: 0% ±

Excel 2003
Цитата
Цитата
подсказка больше никак быстрее работать не будет

Может убрать затенение, оно вам нужно.
Закомментируйте блок с
[vba]
Код
With Selection.ShapeRange.Shadow
[/vba]
 
Ответить
Сообщение
Цитата
Цитата
подсказка больше никак быстрее работать не будет

Может убрать затенение, оно вам нужно.
Закомментируйте блок с
[vba]
Код
With Selection.ShapeRange.Shadow
[/vba]

Автор - Kuzmich
Дата добавления - 03.01.2021 в 11:19
ekut Дата: Воскресенье, 03.01.2021, 16:21 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 123
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Спасибо большое!!!!!
 
Ответить
СообщениеСпасибо большое!!!!!

Автор - ekut
Дата добавления - 03.01.2021 в 16:21
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Всплывающая подсказка (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования Jobsora jooble
© 2010-2021 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!