Как синхронизировать выпадающие списки на нескольких листах в Excel?

Предположим, у вас есть раскрывающиеся списки на нескольких листах рабочей книги, которые содержат одни и те же раскрывающиеся элементы. Теперь вы хотите синхронизировать раскрывающиеся списки на рабочих листах, чтобы при выборе элемента из раскрывающегося списка на одном рабочем листе раскрывающиеся списки на других рабочих листах автоматически синхронизировались с тем же выбором. В этой статье представлен код VBA, который поможет вам решить эту проблему.

Синхронизируйте раскрывающиеся списки на нескольких листах с кодом VBA

Синхронизируйте раскрывающиеся списки на нескольких листах с кодом VBA

Например, раскрывающиеся списки находятся на пяти рабочих листах с именами Лист1, Лист2, ..., Лист5, чтобы синхронизировать раскрывающиеся списки на других листах в соответствии с раскрывающимся выбором на Листе 1, примените следующий код VBA, чтобы сделать это.

1. Откройте Sheet1, щелкните правой кнопкой мыши вкладку листа и выберите Просмотреть код из контекстного меню.

2. в Microsoft Visual Basic для приложений окно, вставьте следующий код VBA в Лист1 (Код) окно.

Код 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("Лист5")

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, Издатель, доступ, Visio и проект.
Открывайте и создавайте несколько документов на новых вкладках одного окна, а не в новых окнах.
Повышает вашу продуктивность на 50% и сокращает количество щелчков мышью на сотни каждый день!

Больше информации... Скачать бесплатно... Покупка ...

Комментарии (5)

Оценок пока нет. Оцените первым!

О 3 месяцев назад

#40764

Этот комментарий был сведен к минимуму модератором на сайте

Здравствуйте,

Как я могу это сделать, если мои выпадающие списки находятся в разных диапазонах? Чтобы уточнить, у меня есть одно раскрывающееся меню на листе 7, которое находится в ячейке B7, и такое же раскрывающееся меню на листе 6 в ячейке B2.

Спасибо,
Elaine

Ответить

кристалл E

О 3 месяцев назад

#40859

Этот комментарий был сведен к минимуму модератором на сайте

Привет Э,
Следующий код VBA может помочь.
Здесь я беру Sheet6 в качестве основного рабочего листа, щелкаю правой кнопкой мыши вкладку листа, выбираю View Code из контекстного меню, затем копирую следующий код в окно Sheet6 (Code). Когда вы выбираете любой элемент из раскрывающегося списка в B2 на Sheet6, раскрывающийся список в B7 на Sheet7 будет синхронизирован, чтобы иметь тот же выбранный элемент.

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

Ответить

Report

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

О 3 месяцев назад

#40991

Этот комментарий был сведен к минимуму модератором на сайте

Привет Э,
Что-то не так с кодом 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

Ответить

Report

О 3 месяцев назад

#40890

Этот комментарий был сведен к минимуму модератором на сайте

Кристалл,

Большое спасибо за ваш ответ, это сработало! Как я могу изменить код, чтобы добавить еще одну ячейку на тот же лист 6, B3, который также необходимо синхронизировать с B8 на листе 7? Я попытался изменить его ниже, однако в итоге содержимое B3 помещается на лист 6 в B7 на листе 7 вместо B8.

Private Sub Worksheet_Change (ByVal Target As Range)
'Обновлено Extendoffice 20221025
Dim tSheet1 как рабочий лист
Dim tRange1 как диапазон
Dim tRange2 как диапазон
Dim xRangeStr1 как строка
Dim xRangeStr2 как строка
On Error Resume Next
Если Target.Count > 1, то выйдите из Sub

xRangeStr1 = "B2"
xRangeStr2 = "B3"

Установите tRange1 = Диапазон («B7»)
Если не tRange1, то ничего, тогда
xRangeStr1 = tRange1.Адрес
Application.EnableEvents = False
Установите tSheet1 = ActiveWorkbook.Worksheets("Лист7")
tSheet1.Range(xRangeStr1).Value = Target.Value
Application.EnableEvents = True
End If

Установите tRange2 = Диапазон («B8»)
Если не tRange2, то ничего, тогда
xRangeStr2 = tRange2.Адрес
Application.EnableEvents = False
Установите tSheet1 = ActiveWorkbook.Worksheets("Лист7")
tSheet1.Range(xRangeStr2).Value = Target.Value
Application.EnableEvents = True
End If

End Sub

Ответить

Здесь еще нет комментариев

Оставляйте свои комментарии

Публикация как гость

Логин

Имя (обязательно)

E-mail (обязательно)

Оценить этот пост:

Сброс

0 Характеристики

Я согласен с условия и сроки