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

Вход

Регистрация

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

 

= Мир MS Excel/Размещение фигур в определенных ячейках. - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Размещение фигур в определенных ячейках. (Макросы/Sub)
Размещение фигур в определенных ячейках.
ПутинВВ Дата: Воскресенье, 10.02.2019, 06:14 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 17
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Здравствуйте, гуру экселя.
Помогите разрешить вопрос.

У меня есть макрос, который помещает фигуру из ячейки K1 - в ячейки, содержащие текст, представленный в ячейке O1.

Как по аналогии с этим макросом - для фигур из диапазона R6:R8 - назначить ячейкам с содержимым S6:S8 ?
Соответствующим фигурам нужно переместится к центрам этих ячеек (имеются ввиду ячейки, содержащие текст из диапазона S6:S8 ).
К сообщению приложен файл: 4842412.xls(67.5 Kb)


Сообщение отредактировал ПутинВВ - Воскресенье, 10.02.2019, 06:17
 
Ответить
СообщениеЗдравствуйте, гуру экселя.
Помогите разрешить вопрос.

У меня есть макрос, который помещает фигуру из ячейки K1 - в ячейки, содержащие текст, представленный в ячейке O1.

Как по аналогии с этим макросом - для фигур из диапазона R6:R8 - назначить ячейкам с содержимым S6:S8 ?
Соответствующим фигурам нужно переместится к центрам этих ячеек (имеются ввиду ячейки, содержащие текст из диапазона S6:S8 ).

Автор - ПутинВВ
Дата добавления - 10.02.2019 в 06:14
ПутинВВ Дата: Воскресенье, 10.02.2019, 19:33 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 17
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
В общем я тут сам пытался что-то сделать.

Намудрил вот такой макрос, но он мне кажется неимоверно большим.
[vba]
Код

Sub Общий1()

ActiveSheet.Shapes("ОбъектX 001").Delete
ActiveSheet.Shapes("ОбъектY 001").Delete
ActiveSheet.Shapes("ОбъектZ 001").Delete

Макрос1
Макрос2
Макрос3

Range("A1").Select

End Sub

Sub Макрос1()
    Dim rx, adr, fn, zd, x, y, z, zz, cnt&
    zd = [R6]
    fn = [S6]
    For Each x In ActiveSheet.Shapes
      If x.Name Like "ОбъектX*" Then x.Delete
    Next
    Set z = ActiveSheet.Shapes(zd)
    With ActiveSheet.Cells
        Set rx = .Find(fn)
        If Not rx Is Nothing Then
            adr = rx.Address
            Do
                If rx.Address <> "$S$6" Then
                    rx.Select
                    x = rx.Left + rx.Width - z.Width
                    y = rx.Top
                    z.Copy
                    ActiveSheet.Paste: cnt = cnt + 1
                    Selection.Left = x:  Selection.Name = "ОбъектX" & Format(cnt, " 000")
                End If
                Set rx = .FindNext(rx)
            Loop While rx.Address <> adr
        End If
    End With
End Sub

Sub Макрос2()
    Dim rx, adr, fn, zd, x, y, z, zz, cnt&
    zd = [R7]
    fn = [S7]
    For Each x In ActiveSheet.Shapes
      If x.Name Like "ОбъектY*" Then x.Delete
    Next
    Set z = ActiveSheet.Shapes(zd)
    With ActiveSheet.Cells
        Set rx = .Find(fn)
        If Not rx Is Nothing Then
            adr = rx.Address
            Do
                If rx.Address <> "$S$7" Then
                    rx.Select
                    x = rx.Left + rx.Width - z.Width
                    y = rx.Top
                    z.Copy
                    ActiveSheet.Paste: cnt = cnt + 1
                    Selection.Left = x:  Selection.Name = "ОбъектY" & Format(cnt, " 000")
                End If
                Set rx = .FindNext(rx)
            Loop While rx.Address <> adr
        End If
    End With
End Sub

Sub Макрос3()
    Dim rx, adr, fn, zd, x, y, z, zz, cnt&
    zd = [R8]
    fn = [S8]
    For Each x In ActiveSheet.Shapes
      If x.Name Like "ОбъектZ*" Then x.Delete
    Next
    Set z = ActiveSheet.Shapes(zd)
    With ActiveSheet.Cells
        Set rx = .Find(fn)
        If Not rx Is Nothing Then
            adr = rx.Address
            Do
                If rx.Address <> "$S$8" Then
                    rx.Select
                    x = rx.Left + rx.Width - z.Width
                    y = rx.Top
                    z.Copy
                    ActiveSheet.Paste: cnt = cnt + 1
                    Selection.Left = x:  Selection.Name = "ОбъектZ" & Format(cnt, " 000")
                End If
                Set rx = .FindNext(rx)
            Loop While rx.Address <> adr
        End If
    End With
End Sub
[/vba]

Потому что я по сути написал три похожих макроса - для трех ячеек с именами фигур.
А тут надо видимо как-то массив использовать.
Подскажите, как заменить эти громоздкие макросы на макрос работающий с массивом ячеек R6:S8 ?
К сообщению приложен файл: 1-2-.xls(72.5 Kb)
 
Ответить
СообщениеВ общем я тут сам пытался что-то сделать.

Намудрил вот такой макрос, но он мне кажется неимоверно большим.
[vba]
Код

Sub Общий1()

ActiveSheet.Shapes("ОбъектX 001").Delete
ActiveSheet.Shapes("ОбъектY 001").Delete
ActiveSheet.Shapes("ОбъектZ 001").Delete

Макрос1
Макрос2
Макрос3

Range("A1").Select

End Sub

Sub Макрос1()
    Dim rx, adr, fn, zd, x, y, z, zz, cnt&
    zd = [R6]
    fn = [S6]
    For Each x In ActiveSheet.Shapes
      If x.Name Like "ОбъектX*" Then x.Delete
    Next
    Set z = ActiveSheet.Shapes(zd)
    With ActiveSheet.Cells
        Set rx = .Find(fn)
        If Not rx Is Nothing Then
            adr = rx.Address
            Do
                If rx.Address <> "$S$6" Then
                    rx.Select
                    x = rx.Left + rx.Width - z.Width
                    y = rx.Top
                    z.Copy
                    ActiveSheet.Paste: cnt = cnt + 1
                    Selection.Left = x:  Selection.Name = "ОбъектX" & Format(cnt, " 000")
                End If
                Set rx = .FindNext(rx)
            Loop While rx.Address <> adr
        End If
    End With
End Sub

Sub Макрос2()
    Dim rx, adr, fn, zd, x, y, z, zz, cnt&
    zd = [R7]
    fn = [S7]
    For Each x In ActiveSheet.Shapes
      If x.Name Like "ОбъектY*" Then x.Delete
    Next
    Set z = ActiveSheet.Shapes(zd)
    With ActiveSheet.Cells
        Set rx = .Find(fn)
        If Not rx Is Nothing Then
            adr = rx.Address
            Do
                If rx.Address <> "$S$7" Then
                    rx.Select
                    x = rx.Left + rx.Width - z.Width
                    y = rx.Top
                    z.Copy
                    ActiveSheet.Paste: cnt = cnt + 1
                    Selection.Left = x:  Selection.Name = "ОбъектY" & Format(cnt, " 000")
                End If
                Set rx = .FindNext(rx)
            Loop While rx.Address <> adr
        End If
    End With
End Sub

Sub Макрос3()
    Dim rx, adr, fn, zd, x, y, z, zz, cnt&
    zd = [R8]
    fn = [S8]
    For Each x In ActiveSheet.Shapes
      If x.Name Like "ОбъектZ*" Then x.Delete
    Next
    Set z = ActiveSheet.Shapes(zd)
    With ActiveSheet.Cells
        Set rx = .Find(fn)
        If Not rx Is Nothing Then
            adr = rx.Address
            Do
                If rx.Address <> "$S$8" Then
                    rx.Select
                    x = rx.Left + rx.Width - z.Width
                    y = rx.Top
                    z.Copy
                    ActiveSheet.Paste: cnt = cnt + 1
                    Selection.Left = x:  Selection.Name = "ОбъектZ" & Format(cnt, " 000")
                End If
                Set rx = .FindNext(rx)
            Loop While rx.Address <> adr
        End If
    End With
End Sub
[/vba]

Потому что я по сути написал три похожих макроса - для трех ячеек с именами фигур.
А тут надо видимо как-то массив использовать.
Подскажите, как заменить эти громоздкие макросы на макрос работающий с массивом ячеек R6:S8 ?

Автор - ПутинВВ
Дата добавления - 10.02.2019 в 19:33
krosav4ig Дата: Воскресенье, 10.02.2019, 20:40 | Сообщение № 3
Группа: Друзья
Ранг: Старожил
Сообщений: 1851
Репутация: 795 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Здравствуйте
[vba]
Код
Option Explicit
Sub Общий()
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0
        With ActiveSheet
            DuplicateShapes .[O1], .[K1], "Звездочка", _
                            .[S6], .[R6], "ОбъектX", _
                            .[S7], .[R7], "ОбъектY", _
                            .[S8], .[R8], "ОбъектZ"
        End With
        .ScreenUpdating = 1: .EnableEvents = 1
    End With
End Sub

Private Sub DuplicateShapes(ParamArray arg() As Variant)
    Dim arr() As Variant, lc As Range, c As Range, x As Shape, i&, cnt&
    For i = 0 To UBound(arg) \ 3
        For Each x In arg(i * 3).Parent.Shapes
          If x.Name Like arg(i * 3 + 2) & "*" Then x.Delete
        Next
        With arg(i * 3).Parent.UsedRange
            arr = .Formula
            Set lc = .SpecialCells(11).Offset(1, 1)
            .Replace "*" & arg(i * 3) & "*", "=" & lc.Address, xlWhole
            For Each c In lc.DirectDependents
                If c.Address <> arg(i * 3).Address Then
                    With ActiveSheet.Shapes(arg(i * 3 + 1)).Duplicate
                        cnt = cnt + 1: .Left = c.Left + c.Width - .Width
                        .Top = c.Top: .Name = arg(i * 3 + 2) & Format(cnt, " 000")
                    End With
                End If
            Next
            .Formula = arr
        End With
    Next
End Sub
[/vba]
К сообщению приложен файл: 7496095.xls(91.0 Kb)


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Воскресенье, 10.02.2019, 20:41
 
Ответить
СообщениеЗдравствуйте
[vba]
Код
Option Explicit
Sub Общий()
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0
        With ActiveSheet
            DuplicateShapes .[O1], .[K1], "Звездочка", _
                            .[S6], .[R6], "ОбъектX", _
                            .[S7], .[R7], "ОбъектY", _
                            .[S8], .[R8], "ОбъектZ"
        End With
        .ScreenUpdating = 1: .EnableEvents = 1
    End With
End Sub

Private Sub DuplicateShapes(ParamArray arg() As Variant)
    Dim arr() As Variant, lc As Range, c As Range, x As Shape, i&, cnt&
    For i = 0 To UBound(arg) \ 3
        For Each x In arg(i * 3).Parent.Shapes
          If x.Name Like arg(i * 3 + 2) & "*" Then x.Delete
        Next
        With arg(i * 3).Parent.UsedRange
            arr = .Formula
            Set lc = .SpecialCells(11).Offset(1, 1)
            .Replace "*" & arg(i * 3) & "*", "=" & lc.Address, xlWhole
            For Each c In lc.DirectDependents
                If c.Address <> arg(i * 3).Address Then
                    With ActiveSheet.Shapes(arg(i * 3 + 1)).Duplicate
                        cnt = cnt + 1: .Left = c.Left + c.Width - .Width
                        .Top = c.Top: .Name = arg(i * 3 + 2) & Format(cnt, " 000")
                    End With
                End If
            Next
            .Formula = arr
        End With
    Next
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 10.02.2019 в 20:40
ПутинВВ Дата: Воскресенье, 10.02.2019, 21:56 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 17
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
krosav4ig, не работает.
Выдает ошибку - Run-time error. Индекс указанного набора выходит за допустимые пределы.

При этом макрос заменяет содержимое всех ячеек на листе - нулями.
 
Ответить
Сообщениеkrosav4ig, не работает.
Выдает ошибку - Run-time error. Индекс указанного набора выходит за допустимые пределы.

При этом макрос заменяет содержимое всех ячеек на листе - нулями.

Автор - ПутинВВ
Дата добавления - 10.02.2019 в 21:56
krosav4ig Дата: Воскресенье, 10.02.2019, 23:50 | Сообщение № 5
Группа: Друзья
Ранг: Старожил
Сообщений: 1851
Репутация: 795 ±
Замечаний: 0% ±

Excel 2007,2010,2013
ПутинВВ, в приложенном мной файле все работает, показывайте свой файл


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
СообщениеПутинВВ, в приложенном мной файле все работает, показывайте свой файл

Автор - krosav4ig
Дата добавления - 10.02.2019 в 23:50
ПутинВВ Дата: Понедельник, 11.02.2019, 00:07 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 17
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
krosav4ig, да разобрался.
Вроде бы действительно все работает.

У меня вопрос к вам:
Скажите - как вы реализовали в своем макросе - механизм удаления по имени ?

В моем коде указано, например:
[vba]
Код
ActiveSheet.Shapes("ОбъектX 001").Delete
[/vba]

А у вас указано:
[vba]
Код
If x.Name Like arg(i * 3 + 2) & "*" Then x.Delete
[/vba]
Но как макрос в вашем коде узнает - что именно надо удалять - какое имя фигуры ?
 
Ответить
Сообщениеkrosav4ig, да разобрался.
Вроде бы действительно все работает.

У меня вопрос к вам:
Скажите - как вы реализовали в своем макросе - механизм удаления по имени ?

В моем коде указано, например:
[vba]
Код
ActiveSheet.Shapes("ОбъектX 001").Delete
[/vba]

А у вас указано:
[vba]
Код
If x.Name Like arg(i * 3 + 2) & "*" Then x.Delete
[/vba]
Но как макрос в вашем коде узнает - что именно надо удалять - какое имя фигуры ?

Автор - ПутинВВ
Дата добавления - 11.02.2019 в 00:07
krosav4ig Дата: Понедельник, 11.02.2019, 02:46 | Сообщение № 7
Группа: Друзья
Ранг: Старожил
Сообщений: 1851
Репутация: 795 ±
Замечаний: 0% ±

Excel 2007,2010,2013
ну дык все аргументы через paramarray передаются
[vba]
Код
DuplicateShapes .[O1], .[K1], "Звездочка", _
.[S6], .[R6], "ОбъектX", _
.[S7], .[R7], "ОбъектY", _
.[S8], .[R8], "ОбъектZ"
[/vba]
[vba]
Код
DuplicateShapes ЯчейкаСИскомымТекстом, ИмяФигуры, ПрефиксДубликатаФигуры, [...]
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Понедельник, 11.02.2019, 02:56
 
Ответить
Сообщениену дык все аргументы через paramarray передаются
[vba]
Код
DuplicateShapes .[O1], .[K1], "Звездочка", _
.[S6], .[R6], "ОбъектX", _
.[S7], .[R7], "ОбъектY", _
.[S8], .[R8], "ОбъектZ"
[/vba]
[vba]
Код
DuplicateShapes ЯчейкаСИскомымТекстом, ИмяФигуры, ПрефиксДубликатаФигуры, [...]
[/vba]

Автор - krosav4ig
Дата добавления - 11.02.2019 в 02:46
ПутинВВ Дата: Понедельник, 11.02.2019, 07:26 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 17
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
krosav4ig, ясно. Спасибо.
 
Ответить
Сообщениеkrosav4ig, ясно. Спасибо.

Автор - ПутинВВ
Дата добавления - 11.02.2019 в 07:26
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Размещение фигур в определенных ячейках. (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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