Скопируйте и вставьте кнопку activeX

Question

• 1000 1003 * Пользователь нажал «Копировать в»:

Открыто всплывающее окно: Разрешить пользователю выбирать любую ячейку на листе или вручную вводить ссылку на ячейку назначения.

Когда я нажимаю кнопку «ОК», копия кнопки должна быть в E14

Пользовательское меню:

Sub RClickMenu()

Dim MenuItem As CommandBarPopup
Dim ListType As String
ListType = "Lists"

' Add the popup menu.
With Application.CommandBars.Add(Name:=Mname, Position:=msoBarPopup, _
     MenuBar:=False, Temporary:=True)

     ' CODE TYPE.
    Set MenuItem = .Controls.Add(Type:=msoControlPopup)
    With MenuItem
        .caption = "Buttons edit option"

        With .Controls.Add(Type:=msoControlButton)
            .caption = "copy button"
        End With

    End With

End With
End Sub

Событие нажатия мыши при щелчке правой кнопкой мыши:

Public Sub btnFindSections_MouseDown(ByVal button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If button = 1 Then
    ElseIf button = 2 Then
        CreatePopUpMenu
    End If
End Sub

Код для открытия всплывающего окна:

Sub getCellReference()

Dim rng As Range
Dim FormatRuleInput As String

'Get A Cell Address From The User to Get Number Format From
  On Error Resume Next
    Set rng = Application.InputBox( _
      Title:="Copy Code to Cell", _
      Prompt:="Select the cell reference to copy to:", _
      Type:=8)
  On Error GoTo 0
End Sub

После открытия всплывающего окна и получения ссылки на ячейку, как мне скопировать кнопку в новую ячейку?

Answer 1

Попробуйте этот фрагмент кода, чтобы создать событие для вновь созданной кнопки. Вы позвоните Sub, используя ваше имя кнопки. Во время его копирования или после. Теперь вы можете протестировать код для кнопки уже копий. Но код вернет ошибку, если вы попытаетесь запустить его построчно. Запускаем сразу (F5). И будьте осторожны, чтобы не запускать его дважды перед удалением уже созданного события.

Private Sub AddSheetEventButMouseDown(butName As String)
   'It needs a reference to 'Microsoft Visual Basic for Applications Extensibility x.x'
    Dim sh As Worksheet, wProj As VBIDE.VBProject, wCom As VBIDE.VBComponent
    Dim wMod As VBIDE.CodeModule

    Set sh = ActiveSheet 'the sheet where the event must be created!
                         'I used active sheet only for testing...
    With ActiveWorkbook
        Set wProj = .VBProject
        Set wCom = wProj.VBComponents(sh.codename)
        Set wMod = wCom.CodeModule
        With wMod
             .AddFromString "Private Sub " & butName & "_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)" & vbCrLf & _
                            "    If Button = 1 Then" & vbCrLf & _
                            "            MsgBox ""Left clicked""" & vbCrLf & _
                            "    ElseIf Button = 2 Then" & vbCrLf & _
                            "            CreatePopUpMenu" & vbCrLf & _
                            "    End If" & vbCrLf & _
                            "End Sub"
        End With
    End With
End Sub

Он предназначен для создания именно того события, которое вам нужно ...

Вы также можете создать событие Click на том же этапе построение строки таким образом, чтобы она также содержала ее.

Этот фрагмент кода (проще) скопирует кнопку и вызовет вышеуказанный Sub для создания события:

Private Sub testCopyButton(address As String)
 Dim sh As Worksheet, but As Shape, butName As String

 Set sh = ActiveSheet
  butName = "Just_copied"
  Set but = sh.Shapes("btnFindSections")
  but.Copy
  sh.Paste Destination:=sh.Range(address)
  On Error Resume Next
   sh.Shapes(sh.Shapes.count).Name = butName
   If Err.Number = 70 Then
        Err.Clear: On Error GoTo 0
        MsgBox "On the sheet " & sh.Name & ", a button named " & butName & " already exists..." & vbCrLf & _
               "You must delete it, or choose another button name and run the code again.", vbInformation, _
               "Wrong button name"
               sh.Shapes(sh.Shapes.count).Delete 'the last created button is deleted
               Exit Sub
   End If
  On Error GoTo 0

  AddSheetEventButMouseDown butName
End Sub

И тест Sub, вызывающий вышеуказанный, будет:

Sub testCopyButton()
   testCopyButton "O15" 'use here your cell address where to be copied
                        'the sheet name can be also sent and the sub
                        'making the copying needs another parameter...
End Sub