Такой вопрос встал, копирую картинку из одной ячейки в другую. И как у этой скопированной картинки определять имя, высоту/ширину и т.д. Как к ней вообще обращаться, имена у "старой" и новой получаются одинаковые? Как удалить "новую"картинку из ячейки? [vba]
Код
Public Sub test()
Range("A4").Copy Range("C4") End Sub
[/vba]
Такой вопрос встал, копирую картинку из одной ячейки в другую. И как у этой скопированной картинки определять имя, высоту/ширину и т.д. Как к ней вообще обращаться, имена у "старой" и новой получаются одинаковые? Как удалить "новую"картинку из ячейки? [vba]
Sub test() Dim o As Object For Each o In ActiveSheet.Shapes If o.Top > Range("A4").Top And o.Top < Range("A5").Top _ And o.Left > Range("A4").Left And o.Left < Range("B5").Left Then MsgBox o.Name o.Delete End If Next o End Sub
[/vba]
Udik, Я, обычно делаю, типа такого: [vba]
Код
Sub test() Dim o As Object For Each o In ActiveSheet.Shapes If o.Top > Range("A4").Top And o.Top < Range("A5").Top _ And o.Left > Range("A4").Left And o.Left < Range("B5").Left Then MsgBox o.Name o.Delete End If Next o End Sub
Public Sub test() Dim sh As Shape Range("A4").Copy Range("C4") For Each sh In ActiveSheet.Shapes If sh.TopLeftCell.Address = "$C$4" Then MsgBox "Удаляем " & sh.Name & " высотой " & sh.Height & Chr(10) & " из ячейки " & sh.TopLeftCell.Address sh.Delete End If Next sh End Sub
[/vba]
Или типа такого [vba]
Код
Public Sub test() Dim sh As Shape Range("A4").Copy Range("C4") For Each sh In ActiveSheet.Shapes If sh.TopLeftCell.Address = "$C$4" Then MsgBox "Удаляем " & sh.Name & " высотой " & sh.Height & Chr(10) & " из ячейки " & sh.TopLeftCell.Address sh.Delete End If Next sh End Sub
Без перебора всех картинок не обойтись, похоже Немного код модернизировал, чтобы определить находится ли левый верхний угол картинки в проверяемой ячейке. [vba]
Код
Public Sub test() Dim rng1 As Range Dim o As Object
Set rng1 = Range("A4") rng1.Copy Range("C4") For Each o In ActiveSheet.Shapes If o.TopLeftCell.Column = rng1.Column And o.TopLeftCell.Column = rng1.Column Then MsgBox o.Name o.Delete End If Next o End Sub
[/vba]
== Вариант Бороды наиболее интересный, позволяет обойтись без перебора. Пока писал, Лена свой вариант предложила. У меня чет ругаться на Адрес стал, поэтому я через столбцы и строки пошел.
Спасибо всем!
Без перебора всех картинок не обойтись, похоже Немного код модернизировал, чтобы определить находится ли левый верхний угол картинки в проверяемой ячейке. [vba]
Код
Public Sub test() Dim rng1 As Range Dim o As Object
Set rng1 = Range("A4") rng1.Copy Range("C4") For Each o In ActiveSheet.Shapes If o.TopLeftCell.Column = rng1.Column And o.TopLeftCell.Column = rng1.Column Then MsgBox o.Name o.Delete End If Next o End Sub
[/vba]
== Вариант Бороды наиболее интересный, позволяет обойтись без перебора. Пока писал, Лена свой вариант предложила. У меня чет ругаться на Адрес стал, поэтому я через столбцы и строки пошел.
Sub dd() Dim cell(3) As Range, sel(1) As Object, sh As Worksheet, shts As Sheets, I, r As Range, l, t Application.EnableEvents = 0 With ThisWorkbook.Windows(1) Set shts = .SelectedSheets: Set sh = ActiveSheet: Set cell(0) = .VisibleRange(1, 1) Set sel(0) = Selection: Set cell(1) = ActiveCell Set r = [Лист2!A4]: r.Parent.Select Set cell(2) = .VisibleRange(1, 1): Set cell(3) = ActiveCell Set sel(1) = Selection Application.Goto r, 1 For I = 1 To .Panes.Count If Not Intersect(r, .Panes(I).VisibleRange) Is Nothing Then With .Panes(I) Dim pic l = .PointsToScreenPixelsX(r.Left) + 1 t = .PointsToScreenPixelsY(r.Top) + 1 AppActivate (Application.Caption) DoEvents Set pic = ActiveWindow.RangeFromPoint(l, t) Debug.Print pic.Name Stop End With End If Next Application.Goto cell(2): sel(1).Select: cell(3).Activate shts.Select: sh.Activate: Application.Goto cell(0), 1: sel(0).Select: cell(1).Activate Erase cell, sel: Set sh = Nothing: Set shts = Nothing: Set r = Nothing End With Application.EnableEvents = 1 End Sub
[/vba]
Танцы с бубном заказывали? [vba]
Код
Sub dd() Dim cell(3) As Range, sel(1) As Object, sh As Worksheet, shts As Sheets, I, r As Range, l, t Application.EnableEvents = 0 With ThisWorkbook.Windows(1) Set shts = .SelectedSheets: Set sh = ActiveSheet: Set cell(0) = .VisibleRange(1, 1) Set sel(0) = Selection: Set cell(1) = ActiveCell Set r = [Лист2!A4]: r.Parent.Select Set cell(2) = .VisibleRange(1, 1): Set cell(3) = ActiveCell Set sel(1) = Selection Application.Goto r, 1 For I = 1 To .Panes.Count If Not Intersect(r, .Panes(I).VisibleRange) Is Nothing Then With .Panes(I) Dim pic l = .PointsToScreenPixelsX(r.Left) + 1 t = .PointsToScreenPixelsY(r.Top) + 1 AppActivate (Application.Caption) DoEvents Set pic = ActiveWindow.RangeFromPoint(l, t) Debug.Print pic.Name Stop End With End If Next Application.Goto cell(2): sel(1).Select: cell(3).Activate shts.Select: sh.Activate: Application.Goto cell(0), 1: sel(0).Select: cell(1).Activate Erase cell, sel: Set sh = Nothing: Set shts = Nothing: Set r = Nothing End With Application.EnableEvents = 1 End Sub