Move/Copy ComboBox 到不同的 sheet，同时保留代码

Question

在 Sheet1 上，我有一个 ActiveX 组合框，其中列出了所有其他 sheet 的名称。当您 select 一个 sheet 名称时，它运行是工作 sheet 的代码模块上的 ComboBox1_Change 事件，并激活所需的 sheet.

我希望目的地 sheet 具有相同的组合框，以便您可以从那里跳转到另一个 sheet。显而易见的事情是在每个 sheet 上复制组合框，并将 ComboBox1_Change 代码复制到每个 sheet 的模块。

我希望尽可能自动执行此操作，因为有很多 sheet。我很确定我可以自动将组合框移动或复制到 sheet 被 select 编辑的任何内容（可能在 Workbook_SheetActivate 事件上触发）。但是“跳转到这个sheet”代码呢？

我需要 1) 自动将代码复制到每个 sheet，或 2) 将代码放在组合框可以从任何 sheet 运行的中央位置.

Answer 1

这是列表框-class，它在 init-sub 中进行工作sheet。然后检查组合框“lbSheetNames”是否存在 - 如果不存在，则创建它。然后将当前 sheet 个名称添加到列表中。

所有列表框的生成发生在 thisworkbook_activate-event - 对象保存在一个集合中。由于此例程，无需将代码添加到单个工作sheet.

classlbWorksheets

Option Explicit

Private Const lbName As String = "lbSheetNames"

Private m_ws As Worksheet
Private WithEvents m_cbo As MSForms.ComboBox

Public Sub init(ws As Worksheet)

    Set m_ws = ws
    
    addCombo
    fillCboWithSheetNames
    
End Sub

Private Sub addCombo()

    Dim objOLE As OLEObject, fFound As Boolean
    
    For Each objOLE In m_ws.OLEObjects
        If objOLE.Name = lbName Then
            fFound = True
            Exit For
        End If
    Next
    
    If fFound = False Then
        Set objOLE = m_ws.OLEObjects.Add("Forms.Combobox.1")
        With objOLE
            'change to your needs
            .Left = m_ws.Range("A1").Left
            .Top = m_ws.Range("A1").Top
            .Width = 150
            .Name = lbName
        End With
    End If
     
    With objOLE
        Set m_cbo = .Object
    End With

End Sub

Private Sub fillCboWithSheetNames()
Dim ws As Worksheet
m_cbo.List = Array()
For Each ws In ThisWorkbook.Worksheets
    If Not ws Is m_ws Then  'don't add current sheet to listbox
        m_cbo.AddItem ws.Name
    End If
Next
End Sub

Private Sub m_cbo_Change()
    gotoSheet m_cbo.Value
End Sub

Private Sub gotoSheet(wsName As String)

On Error GoTo err_gotoSheet
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(wsName)
    ws.Select
    
exit_gotoSheet:
    Exit Sub
err_gotoSheet:
    MsgBox "Sheet " & wsName & " does not exist.", vbExclamation
    Resume exit_gotoSheet
End Sub

本工作簿模块

Option Explicit

Private m_colListboxes As Collection

Private Sub Workbook_Open()
iniListboxes
End Sub

Private Sub iniListboxes()
Dim ws As Worksheet, lb As lbWorksheets
Set m_colListboxes = New Collection
For Each ws In ThisWorkbook.Worksheets
    Set lb = New lbWorksheets
    lb.init ws
    m_colListboxes.Add lb
Next
End Sub

Move/Copy ComboBox 到不同的 sheet，同时保留代码

Move/Copy ComboBox to different sheet while retaining code

excel

combobox