Я пытаюсь создать макрос, который копирует и вставляет диапазон вместе с объектами в диапазоне в новом месте переменной

Question

Мое намерение состоит в том, чтобы скопировать диапазон вместе с объектами (радиокнопка) и вставить его в динамическое c местоположение (со смещением в 15 столбцов), а затем обновить все ссылки на ячейки вновь вставленных объектов относительно их должность. т. е. если расположение радиокнопки (объекта) = «AF22», то связанная ячейка = 1-й столбец нового диапазона + 11 столбцов справа (например, столбец T + 11 столбцов = столбец «AD»), следовательно, ссылка на новую ячейку = «AD22» РЕДАКТИРОВАТЬ: я удалил часть своего кода, который казался избыточным. Приведенный ниже код прекрасно копирует и вставляет данные и объекты. Однако мне нужна помощь в части Linkedcell

`Sub Macro2()
Dim rng, rng1, rng2 As Range, s As Shape, ws As Worksheet, sr As 
ShapeRange, Loc As String
Set ws = ActiveWorkbook.ActiveSheet
Set rng = ActiveSheet.Range("E19")
Set rng1 = ActiveSheet.Range("T19:AF34")
Set rng2 = ActiveSheet.Range("E19:Q34")

'Copy the range with text and paste it to the desired location

ActiveSheet.Range("E19:Q34").copy

With rng
rng.Offset(0, 15).Select
ws.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

End With

'Trying to find option buttons and give them a new cell reference.(linked cell)
 With ActiveSheet
    'Selection = Range("V19:AC34")
    For Each s In .Shapes
        'if s.TopLeftCell.Column =
         '   .Range ("V19:AC34")

    If s.Name Like "OptionButton*" Then

     s.DrawingObject.LinkedCell = "=" & Chr(s.TopLeftCell.Column) & CStr(s.TopLeftCell.Row)
     Debug.Print s.DrawingObject.LinkedCell

        'Loc = "AD" & s.TopLeftCell.Row
        'Debug.Print Loc
        '.Value = xlOff
        'Selection.LinkedCell = Range(Loc).Address
        '.Display3DShading = False
        End If
 'End With
    Next s
 End With



End Sub`

Answer 1

Попробуйте следующий код, чтобы выбрать / скопировать форму выделения диапазона:

Dim ws As Worksheet, s As Shape, rng As Range, optB As OLEObject
    Set ws = ActiveSheet
    Set rng = sh.Range("your range containing the Option Button to be copied")
    With ws 
      For Each s In .Shapes
        If Not Intersect(Range(s.TopLeftCell.Address), Range(rng.Address)) Is Nothing Then
            If s.Name = "OptionButton1" Then 'use here your option button name
                s.Copy
                Exit For
            End If
        End If
      Next s
    End With
    rng.Cells(1, 1).Offset(0, 15).Select
    ws.Paste
    'Generic way of identifying the newly pasted Option button and allocate a `LinkedCell` to it:
    'Set optB = ws.Shapes(ws.Shapes.Count).OLEFormat.Object
    'optB.LinkedCell = "=" & rng.Cells(1, 1).Offset(0, 15).Address
    Selection.LinkedCell = rng.Cells(1, 1).Offset(0, 15).Address

Для этого необходимо использовать трюк, но с использованием ActiveSheet.Shapes ... Использование rng.Cells.Offset(0, 15).Select не мудро. Это выберет столько ячеек, сколько имеет диапазон. Я решил вставить его, ссылаясь на первую ячейку диапазона. Если вы хотите / нуждаетесь в другой позиции, вам будет легко адаптировать код (rng.Cells()), я думаю.

Отредактировано: я адаптировал код для выбора и копирования только фигуры с именем "OptionButton1". Пожалуйста, позаботьтесь, чтобы использовать здесь свое реальное имя фигуры!

Я также показал способ присвоения LinkedCell недавно созданной Option Button. Я должен признаться, что, глядя на ваш код, я не понял, на какую ячейку вы пытались связать. Я использовал один c один, тот же, что и для перемещения фигуры. Пожалуйста, используйте здесь соответствующий адрес, в соответствии с вашими потребностями.