Як синхронізувати розкривні списки на кількох аркушах у Excel?

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

Синхронізуйте розкривні списки на кількох аркушах за допомогою коду VBA

Синхронізуйте розкривні списки на кількох аркушах за допомогою коду VBA

Наприклад, розкривні списки знаходяться на п’яти робочих аркушах з іменами Аркуш1, Аркуш2, ..., Аркуш5, щоб синхронізувати розкривні списки в інших робочих аркушах відповідно до вибору розкривного списку на Аркуші1, застосуйте наступний код VBA, щоб виконати це.

1. Відкрийте Аркуш1, клацніть правою кнопкою миші вкладку аркуша та виберіть Переглянути код з меню правою кнопкою миші.

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 це робочі аркуші, які містять розкривні списки, які потрібно синхронізувати на основі розкривного списку на Аркуші1;

3) Щоб додати більше аркушів у код, додайте наступні два рядки перед рядком «Application.EnableEvents = True", потім змініть назву аркуша "Sheet5” до потрібного імені.

Установіть tSheet1 = ActiveWorkbook.Worksheets("Sheet5")

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

3 Натисніть кнопку інший + Q клавіші, щоб закрити Microsoft Visual Basic для додатків вікна.

Відтепер, коли ви вибираєте елемент зі спадного списку в Аркуш1, розкривні списки на вказаних робочих аркушах буде автоматично синхронізовано, щоб мати однаковий вибір. Перегляньте наведену нижче демонстрацію.

Демонстрація: синхронізація розкривних списків на кількох аркушах у Excel

Найкращі інструменти для підвищення продуктивності офісу

Kutools для Excel вирішує більшість ваших проблем і збільшує продуктивність на 80%

Повторне використання: Швидко вставте складні формули, діаграми і все, що ви використовували раніше; Шифрувати комірки з паролем; Створити список розсилки та надсилати електронні листи ...
Супер формула бар (легко редагувати кілька рядків тексту та формули); Макет читання (легко читати та редагувати велику кількість комірок); Вставте у відфільтрований діапазон...
Об’єднати клітинки / рядки / стовпці без втрати даних; Вміст розділених комірок; Об'єднати повторювані рядки / стовпці... Запобігання дублюючим клітинам; Порівняйте діапазони...
Виберіть Повторюваний або Унікальний Рядки; Виберіть Пусті рядки (усі клітинки порожні); Супер знахідка та нечітка знахідка у багатьох робочих зошитах; Випадковий вибір ...
Точна копія Кілька клітинок без зміни посилання на формулу; Автоматичне створення посилань на кілька аркушів; Вставте кулі, Прапорці та інше ...
Витяг тексту, Додати текст, Видалити за позицією, Видаліть пробіл; Створення та друк проміжних підсумків підкачки; Перетворення вмісту комірок та коментарів...
Супер фільтр (зберегти та застосувати схеми фільтрів до інших аркушів); Розширене сортування за місяцем / тижнем / днем, частотою та іншим; Спеціальний фільтр жирним, курсивом ...
Поєднайте робочі зошити та робочі аркуші; Об’єднати таблиці на основі ключових стовпців; Розділіть дані на кілька аркушів; Пакетне перетворення xls, xlsx та PDF...
Понад 300 потужних функцій. Підтримує Office / Excel 2007-2021 і 365. Підтримує всі мови. Легке розгортання на вашому підприємстві чи в організації. 30-денна безкоштовна пробна версія повних функцій. 60-денна гарантія повернення грошей.

Детальніше ... Завантажити безкоштовно... Придбати ...

Вкладка Office забезпечує інтерфейс з вкладками для Office і значно спрощує вашу роботу

Увімкніть редагування та читання на вкладках у Word, Excel, PowerPoint, Publisher, Access, Visio та Project.
Відкривайте та створюйте кілька документів на нових вкладках того самого вікна, а не в нових вікнах.
Збільшує вашу продуктивність на 50% та зменшує сотні клацань миші для вас щодня!

Детальніше ... Завантажити безкоштовно... Придбати ...

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

Поки немає оцінок. Оцініть першим!

близько 3 місяців тому

# 40764

Цей коментар був мінімізований модератором на сайті

привіт,

Як я можу це зробити, якщо мої спадні списки знаходяться в різних діапазонах? Щоб уточнити, у мене є одне спадне меню на аркуші 7, що знаходиться в клітинці B7, і таке ж спадне меню на аркуші 6 у клітинці B2.

Спасибі,
Елейн

відповісти

кристал E

близько 3 місяців тому

# 40859

Цей коментар був мінімізований модератором на сайті

Привіт Е,
Наведений нижче код VBA може допомогти.
Тут я взяв аркуш Sheet6 як основний аркуш, клацніть правою кнопкою миші вкладку аркуша, виберіть «Переглянути код» у меню, що відкривається, а потім скопіюйте наступний код у вікні «Аркуш6 (Код)». Коли ви вибираєте будь-який елемент зі спадного списку в 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

відповісти

доповідь

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

відповісти

доповідь

близько 3 місяців тому

# 40890

Цей коментар був мінімізований модератором на сайті

кришталь,

Дуже дякую за відповідь, це спрацювало! Як я можу змінити код, щоб додати іншу клітинку на тому самому аркуші 6, B3, яку також потрібно синхронізувати з B8 на аркуші 7? Я намагався змінити це нижче, однак у підсумку вміст B3 розміщено на аркуші 6 і B7 на аркуші 7 замість B8.

Приватний допоміжний робочий лист_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 = Range("B7")
Якщо не tRange1, то нічого
xRangeStr1 = tRange1.Address
Application.EnableEvents = False
Установіть tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
tSheet1.Range(xRangeStr1).Value = Target.Value
Application.EnableEvents = True
End If

Установіть tRange2 = Range("B8")
Якщо не tRange2, то нічого
xRangeStr2 = tRange2.Address
Application.EnableEvents = False
Установіть tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
tSheet1.Range(xRangeStr2).Value = Target.Value
Application.EnableEvents = True
End If

End Sub

відповісти

There are no comments posted here yet

Залишайте свої коментарі

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

Увійти

Ім'я (обов'язково)

E-mail (обов'язково)

Оцініть цю публікацію:

скидання

0 Персонажі

Я згоден з Терміни та умови