Добрый день, уважаемые форумчане! Прошу у Вас помощи, т.к сама не могу справиться с поставленной задачей.
Есть количество товаров и общая сумма. Нужно чтобы при наведении мышки, скажем на сумму всплывало окошко со стоимостью за единицу. Если необходимо, то можно сделать ячейку с формулой вычисления, которая в итоге будет скрытой. Но желательно без нее. Подскажите пожалуйста, возможно ли это?
Добрый день, уважаемые форумчане! Прошу у Вас помощи, т.к сама не могу справиться с поставленной задачей.
Есть количество товаров и общая сумма. Нужно чтобы при наведении мышки, скажем на сумму всплывало окошко со стоимостью за единицу. Если необходимо, то можно сделать ячейку с формулой вычисления, которая в итоге будет скрытой. Но желательно без нее. Подскажите пожалуйста, возможно ли это?Ksuxa
Private Sub Worksheet_SelectionChange(ByVal Target As Range) UsedRange.ClearComments If Intersect(Target, Range("g12:g65")) Is Nothing Then Exit Sub With Target If .Columns.Count > 1 Then Exit Sub If .Rows.Count > 1 Then Exit Sub On Error Resume Next Price = "Цена за шт. " & Round(.Value / .Offset(0, -1).Value, 2) .AddComment .Comment.Visible = True .Comment.Text Price End With End Sub
[/vba]
Добрый день. Вариант с примечаниями [vba]
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range) UsedRange.ClearComments If Intersect(Target, Range("g12:g65")) Is Nothing Then Exit Sub With Target If .Columns.Count > 1 Then Exit Sub If .Rows.Count > 1 Then Exit Sub On Error Resume Next Price = "Цена за шт. " & Round(.Value / .Offset(0, -1).Value, 2) .AddComment .Comment.Visible = True .Comment.Text Price End With End Sub
Там два макроса. Один сворачивает пустые строки по двум диапазоном, второй сортирует в алфавитном порядке тоже по двум диапазонам.
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Columns(4)) Is Nothing Then Dim iRow1&, iRow2& Dim Rng1 As Range, Rng2 As Range, iKey As Range, sRng As Range Application.ScreenUpdating = False Application.EnableEvents = False On Error Resume Next iRow1 = Columns("D").Find("Канцелярські товари").Row iRow2 = Columns("D").Find("Господарські товари").Row Set Rng1 = Range(Cells(iRow1 + 1, 4), Cells(iRow2 - 1, 93)) Set Rng2 = Range(Cells(iRow2 + 1, 4), Cells(Cells(Rows.Count, "C").End(xlUp).Row - 1, 93)) If Not Intersect(Target, Rng1) Is Nothing Then Set iKey = Cells(iRow1 + 1, 4) Set sRng = Rng1 ElseIf Not Intersect(Target, Rng2) Is Nothing Then Set iKey = Cells(iRow2 + 1, 4) Set sRng = Rng2 End If With Me.Sort .SortFields.Clear .SortFields.Add Key:=iKey, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange sRng .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) r1_ = Range("B" & Rows.Count).End(xlUp).Row If Intersect(Target, Range("AX" & r1_)) Is Nothing Then Range("AX" & r1_).ClearComments Exit Sub End If If Target.Count > 1 Then Exit Sub If Target.Value = " " Then Exit Sub Range("AX" & r1_).ClearComments Target.AddComment Target.Comment.Visible = True ad_ = Target.Offset(-1, -1).Address Target.Comment.Text Text:=Лист1.Range(ad_).Value Target.Comment.Shape.Select True Selection.ShapeRange.AutoShapeType = msoShapeRoundedRectangularCallout Selection.AutoSize = True tl_ = Target.Left tt_ = Target.Top tw_ = Target.Width th_ = Target.Height Selection.ShapeRange.Left = tl_ + tw_ * 2.5 Selection.ShapeRange.Top = tt_ - th_ pw_ = Selection.ShapeRange.Width ph_ = Selection.ShapeRange.Height jj = Selection.ShapeRange.Adjustments.Item(1) oo = Selection.ShapeRange.Adjustments.Item(2) Selection.ShapeRange.Adjustments.Item(1) = -tw_ * 1.5 / pw_ Selection.ShapeRange.Adjustments.Item(2) = th_ / ph_ Target.Select End Sub
Там два макроса. Один сворачивает пустые строки по двум диапазоном, второй сортирует в алфавитном порядке тоже по двум диапазонам.
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Columns(4)) Is Nothing Then Dim iRow1&, iRow2& Dim Rng1 As Range, Rng2 As Range, iKey As Range, sRng As Range Application.ScreenUpdating = False Application.EnableEvents = False On Error Resume Next iRow1 = Columns("D").Find("Канцелярські товари").Row iRow2 = Columns("D").Find("Господарські товари").Row Set Rng1 = Range(Cells(iRow1 + 1, 4), Cells(iRow2 - 1, 93)) Set Rng2 = Range(Cells(iRow2 + 1, 4), Cells(Cells(Rows.Count, "C").End(xlUp).Row - 1, 93)) If Not Intersect(Target, Rng1) Is Nothing Then Set iKey = Cells(iRow1 + 1, 4) Set sRng = Rng1 ElseIf Not Intersect(Target, Rng2) Is Nothing Then Set iKey = Cells(iRow2 + 1, 4) Set sRng = Rng2 End If With Me.Sort .SortFields.Clear .SortFields.Add Key:=iKey, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal .SetRange sRng .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) r1_ = Range("B" & Rows.Count).End(xlUp).Row If Intersect(Target, Range("AX" & r1_)) Is Nothing Then Range("AX" & r1_).ClearComments Exit Sub End If If Target.Count > 1 Then Exit Sub If Target.Value = " " Then Exit Sub Range("AX" & r1_).ClearComments Target.AddComment Target.Comment.Visible = True ad_ = Target.Offset(-1, -1).Address Target.Comment.Text Text:=Лист1.Range(ad_).Value Target.Comment.Shape.Select True Selection.ShapeRange.AutoShapeType = msoShapeRoundedRectangularCallout Selection.AutoSize = True tl_ = Target.Left tt_ = Target.Top tw_ = Target.Width th_ = Target.Height Selection.ShapeRange.Left = tl_ + tw_ * 2.5 Selection.ShapeRange.Top = tt_ - th_ pw_ = Selection.ShapeRange.Width ph_ = Selection.ShapeRange.Height jj = Selection.ShapeRange.Adjustments.Item(1) oo = Selection.ShapeRange.Adjustments.Item(2) Selection.ShapeRange.Adjustments.Item(1) = -tw_ * 1.5 / pw_ Selection.ShapeRange.Adjustments.Item(2) = th_ / ph_ Target.Select End SubKsuxa
Оставьте только нужный лист. Все лишние модули/макросы удалите. Оставьте несколько строк на листе для примера. Все данные не нужны, главное - структура. Можно еще сохранить в xlsb и/или заархивировать.
Ksuxa, оформите код в своем предыдущем сообщении. (Кнопка # в режиме правки поста)
Оставьте только нужный лист. Все лишние модули/макросы удалите. Оставьте несколько строк на листе для примера. Все данные не нужны, главное - структура. Можно еще сохранить в xlsb и/или заархивировать.Manyasha