如何在 Excel 中同步多个工作表中的下拉列表？

假设您在工作簿中的多个工作表上有下拉列表，其中包含完全相同的下拉项。现在，您希望跨工作表同步下拉列表，这样一旦您从一个工作表的下拉列表中选择了一个项目，其他工作表中的下拉列表就会自动同步相同的选择。本文提供了一个 VBA 代码来帮助您解决这个问题。

使用 VBA 代码同步多个工作表中的下拉列表

使用 VBA 代码同步多个工作表中的下拉列表

例如，下拉列表位于五个名为 工作表 1、工作表 2、 ...， 表 5， 要根据Sheet1中的下拉选择同步其他工作表中的下拉列表，请应用以下VBA代码完成。

1.打开Sheet1，右键单击工作表选项卡并选择 查看代码 从右键单击菜单。

2。在里面 Microsoft Visual Basic应用程序 窗口，将以下 VBA 代码粘贴到 Sheet1（代码） 窗口。

VBA代码：同步多个工作表中的下拉列表

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220815
    Dim tSheet1 As Worksheet
    Dim tRange As Range
    Dim xRangeStr As String
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    
    xRangeStr = "A2:A11"

    Set tRange = Intersect(Target, Range(xRangeStr))
    If Not tRange Is Nothing Then
        xRangeStr = tRange.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet2")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet3")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet4")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet5")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Application.EnableEvents = True
    End If
    
End Sub

笔记：

1）在代码中， A2：A11 是包含下拉列表的范围。确保所有下拉列表在不同工作表中的范围相同。

2) 工作表 2、工作表 3、工作表 4 和 Sheet5 是包含要根据 Sheet1 中的下拉列表同步的下拉列表的工作表；

3）要在代码中添加更多工作表，请在“行”之前添加以下两行Application.EnableEvents = True”，然后更改工作表名称“Sheet5”到您需要的名称。

设置 tSheet1 = ActiveWorkbook.Worksheets("Sheet5")

tSheet1.Range(xRangeStr).Value = Target.Value 值

3。按其他 + Q 关闭键 Microsoft Visual Basic应用程序 窗口。

从现在开始，当您从下拉列表中选择一个项目时 表 1， 指定工作表中的下拉列表将自动同步以具有相同的选择。请参阅下面的演示。

演示：在 Excel 中同步多个工作表中的下拉列表

最佳办公效率工具

Kutools for Excel解决了您的大多数问题，并使您的生产率提高了80％

重用: 快速插入 复杂的公式，图表 以及您以前使用过的任何东西；加密单元带密码创建邮件列表并发送电子邮件...
超级公式栏（轻松编辑多行文本和公式）；阅读版式（轻松读取和编辑大量单元格）；粘贴到过滤范围...
合并单元格/行/列不会丢失数据；拆分单元格内容；合并重复的行/列...防止细胞重复；比较范围...
选择重复或唯一行; 选择空白行（所有单元格都是空的）；超级查找和模糊查找在许多工作簿中；随机选择...
确切的副本多个单元格，无需更改公式参考；自动创建参考到多张纸；插入项目符号，复选框等...
提取文字，添加文本，按位置删除，删除空间; 创建和打印分页小计；在单元格内容和注释之间转换...
超级滤镜（将过滤方案保存并应用于其他工作表）；高级排序按月/周/日，频率及更多；特殊过滤器用粗体，斜体...
结合工作簿和工作表; 根据关键列合并表；将数据分割成多个工作表; 批量转换xls，xlsx和PDF...
超过300种强大功能. 支持 Office / Excel 2007-2021 和 365。支持所有语言。在您的企业或组织中轻松部署。完整功能 30 天免费试用。 60 天退款保证。

阅读更多免费下载... 采购...

Office选项卡为Office带来了选项卡式界面，使您的工作更加轻松

在Word，Excel，PowerPoint中启用选项卡式编辑和阅读，发布者，Access，Visio和Project。
在同一窗口的新选项卡中而不是在新窗口中打开并创建多个文档。
每天将您的工作效率提高50％，并减少数百次鼠标单击！

阅读更多免费下载... 采购...

注释 (5)

还没有评分。成为第一位评论！

大约3个月前

#40764

该评论由网站上的主持人最小化

嗨，

如果我的下拉菜单在不同的范围内，我该怎么做？详细地说，我在单元格 B7 中的工作表 7 中有一个下拉菜单，在单元格 B6 的工作表 2 上有相同的下拉菜单。

谢谢，
伊莱恩

水晶 E

大约3个月前

#40859

该评论由网站上的主持人最小化

嗨，E，
以下 VBA 代码可以提供帮助。
这里我以Sheet6为主工作表，右键工作表标签，在右键菜单中选择查看代码，然后在Sheet6（代码）窗口中复制如下代码。当您从 Sheet2 的 B6 中的下拉列表中选择任何项目时，Sheet7 的 B7 中的下拉列表将同步为具有相同的选定项。

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20221025
    Dim tSheet1 As Worksheet
    Dim tRange As Range
    Dim xRangeStr As String
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    
    xRangeStr = "B2"
    
    Set tRange = Range("B7")
    If Not tRange Is Nothing Then
        xRangeStr = tRange.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Application.EnableEvents = True
    End If
    
End Sub

报告

E 水晶

大约3个月前

#40915

该评论由网站上的主持人最小化

嗨水晶，

非常感谢您的回复，您的代码有效！我分别在 b2 和 b7、b3 和 b8 下方有一个单元格，它们需要具有相同的功能。我试图重写您的代码，如下所示，但这不起作用。当我更改 b7 时，它导致 b8 而不是 b3 更改。你能确定我做错了什么吗？

太谢谢你了！

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20221025
    Dim tSheet1 As Worksheet
    Dim tRange1 As Range
    Dime tRange2 As Range
    Dim xRangeStr1 As String
    Dim xRangeStr2 As String
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    
    xRangeStr1 = "B2"
    xRangeStr2="B3"
    
    Set tRange1 = Range("B7")
    If Not tRange1 Is Nothing Then
        xRangeStr1 = tRange1.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
        tSheet1.Range(xRangeStr1).Value = Target.Value
        Application.EnableEvents = True
    End If
    
    Set tRange2 = Range("B8")
    If Not tRange2 Is Nothing Then
        xRangeStr2 = tRange2.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
        tSheet1.Range(xRangeStr2).Value = Target.Value
        Application.EnableEvents = True
    End If

End Sub

水晶 E

大约2个月前

#40991

该评论由网站上的主持人最小化

嗨，E，
我在上面回复你的 VBA 代码有问题。
对于您提到的新问题，请尝试以下代码。

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20221031
    
    Dim xBool1 As Boolean
    Dim xBool2 As Boolean
    Dim xRgStr As String
    Dim tRange As Range
    
    xRangeStr1 = "B2"
    xRangeStr2 = "B3"
    xRgStr = ""
    
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    xBool1 = Intersect(Target, Range(xRangeStr1)) Is Nothing
    xBool2 = Intersect(Target, Range(xRangeStr2)) Is Nothing
    
    If xBool1 And xBool2 Then Exit Sub
    
    xRgStr = Target.Address(False, False, xlA1, False, False)
    
    If Target.Address(False, False, xlA1, False, False) = xRangeStr1 Then
        xRgStr = "b7"
    ElseIf Target.Address(False, False, xlA1, False, False) = xRangeStr2 Then
        xRgStr = "b8"
    End If
    If xRgStr = "" Then Exit Sub
    
    Application.EnableEvents = False
    Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
    tSheet1.Range(xRgStr).Value = Target.Value
    Application.EnableEvents = True

End Sub

报告

大约3个月前

#40890

该评论由网站上的主持人最小化

水晶，

非常感谢您的回复，这有效！如何修改代码以在同一张表 6 中添加另一个单元格，B3 也需要与表 8 中的 B7 同步？我试图在下面对其进行修改，但最终将 B3 的内容放在第 6 页的 B7 的第 7 页而不是 B8 上。

私人子Worksheet_Change（按目标的ByVal目标）
'更新者 Extendoffice 20221025
将 tSheet1 调暗为工作表
将 tRange1 调暗为范围
将 tRange2 调暗为范围
将 xRangeStr1 调暗为字符串
将 xRangeStr2 调暗为字符串
出错时继续下一步
如果 Target.Count > 1 则退出 Sub

xRangeStr1 = "B2"
xRangeStr2 = "B3"

设置 tRange1 = Range("B7")
If Not tRange1 is nothing 那么
xRangeStr1 = tRange1.地址
Application.EnableEvents = False
设置 tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
tSheet1.Range(xRangeStr1).Value = Target.Value 值
Application.EnableEvents = True
结束如果

设置 tRange2 = Range("B8")
If Not tRange2 is nothing 那么
xRangeStr2 = tRange2.地址
Application.EnableEvents = False
设置 tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
tSheet1.Range(xRangeStr2).Value = Target.Value 值
Application.EnableEvents = True
结束如果

END SUB

这里还没有评论

留下你的意见

以访客身份发帖

名字（必填）

电子邮件（必填）

评价此帖子：

重设

0 产品特性

我同意附带条约