Note: The other languages of the website are Google-translated. Back to English

Jak zsynchronizować listy rozwijane w wielu arkuszach roboczych w programie Excel?

Załóżmy, że masz listy rozwijane w kilku arkuszach roboczych w skoroszycie, które zawierają dokładnie te same elementy rozwijane. Teraz chcesz zsynchronizować listy rozwijane w arkuszach roboczych, aby po wybraniu elementu z listy rozwijanej w jednym arkuszu, listy rozwijane w innych arkuszach były automatycznie synchronizowane z tym samym wyborem. Ten artykuł zawiera kod VBA, który pomoże Ci rozwiązać ten problem.

Synchronizuj listy rozwijane w wielu arkuszach roboczych z kodem VBA


Synchronizuj listy rozwijane w wielu arkuszach roboczych z kodem VBA

Na przykład listy rozwijane znajdują się w pięciu arkuszach o nazwie Arkusz1, Arkusz2, ... Arkusz5, aby zsynchronizować listy rozwijane w innych arkuszach roboczych zgodnie z wyborem rozwijanym w Arkuszu1, zastosuj następujący kod VBA, aby to zrobić.

1. Otwórz Arkusz1, kliknij prawym przyciskiem myszy kartę arkusza i wybierz Wyświetl kod z menu prawego przycisku myszy.

2. w Microsoft Visual Basic for Applications okno, wklej następujący kod VBA do Arkusz1 (Kod) okno.

Kod VBA: Synchronizuj listę rozwijaną w wielu arkuszach roboczych

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

Uwagi:

1) W kodzie, A2: A11 to zakres zawierający listę rozwijaną. Upewnij się, że wszystkie listy rozwijane znajdują się w tym samym zakresie w różnych arkuszach.
2) Arkusz2, Arkusz3, Arkusz4 i Sheet5 to arkusze zawierające listy rozwijane, które chcesz zsynchronizować na podstawie listy rozwijanej w Arkuszu1;
3) Aby dodać więcej arkuszy w kodzie, dodaj następujące dwa wiersze przed wierszem „Application.EnableEvents = True”, a następnie zmień nazwę arkusza „Sheet5” na nazwę, której potrzebujesz.
Ustaw tSheet1 = ActiveWorkbook.Worksheets("Arkusz5")
tSheet1.Range(xRangeStr).Value = Target.Value

3. wciśnij inny + Q klucze do zamknięcia Microsoft Visual Basic for Applications okno.

Od teraz, po wybraniu elementu z rozwijanej listy w Arkusz1, listy rozwijane w określonych arkuszach roboczych zostaną zsynchronizowane automatycznie, aby mieć ten sam wybór. Zobacz poniższe demo.


Demo: Synchronizuj listy rozwijane w wielu arkuszach roboczych w programie Excel


Najlepsze narzędzia biurowe

Kutools dla programu Excel rozwiązuje większość problemów i zwiększa produktywność o 80%

  • Ponowne użycie: Szybko włóż złożone wzory, wykresy i wszystko, czego używałeś wcześniej; Szyfruj komórki z hasłem; Utwórz listę mailingową i wysyłaj e-maile ...
  • Pasek Super Formula (łatwo edytować wiele wierszy tekstu i formuły); Układ do czytania (łatwe odczytywanie i edytowanie dużej liczby komórek); Wklej do filtrowanego zakresu...
  • Scal komórki / wiersze / kolumny bez utraty danych; Podziel zawartość komórek; Połącz zduplikowane wiersze / kolumny... Zapobiegaj zduplikowanym komórkom; Porównaj zakresy...
  • Wybierz Duplikat lub Unikalny Wydziwianie; Wybierz puste wiersze (wszystkie komórki są puste); Super Find i Fuzzy Find w wielu zeszytach ćwiczeń; Losowy wybór ...
  • Dokładna kopia Wiele komórek bez zmiany odwołania do formuły; Automatyczne tworzenie odniesień do wielu arkuszy; Wstaw punktory, Pola wyboru i nie tylko ...
  • Wyodrębnij tekst, Dodaj tekst, Usuń według pozycji, Usuń przestrzeń; Tworzenie i drukowanie podsumowań stronicowania; Konwertuj zawartość komórek i komentarze...
  • Super filtr (zapisz i zastosuj schematy filtrów do innych arkuszy); Zaawansowane sortowanie według miesiąca / tygodnia / dnia, częstotliwości i innych; Specjalny filtr pogrubieniem, kursywą ...
  • Połącz skoroszyty i arkusze robocze; Scal tabele na podstawie kluczowych kolumn; Podziel dane na wiele arkuszy; Konwersja wsadowa xls, xlsx i PDF...
  • Ponad 300 zaawansowanych funkcji. Obsługuje Office / Excel 2007-2021 i 365. Obsługuje wszystkie języki. Łatwe wdrażanie w przedsiębiorstwie lub organizacji. Pełne funkcje 30-dniowa bezpłatna wersja próbna. 60-dniowa gwarancja zwrotu pieniędzy.
karta kte 201905

Karta Office wprowadza interfejs z zakładkami do pakietu Office i znacznie ułatwia pracę

  • Włącz edycję i czytanie na kartach w programach Word, Excel, PowerPoint, Publisher, Access, Visio i Project.
  • Otwieraj i twórz wiele dokumentów w nowych kartach tego samego okna, a nie w nowych oknach.
  • Zwiększa produktywność o 50% i redukuje setki kliknięć myszką każdego dnia!
officetab dół
Sortuj komentarze według
Komentarze (5)
Brak ocen. Oceń jako pierwszy!
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć,

Jak mogę to zrobić, jeśli moje listy rozwijane znajdują się w różnych zakresach? Aby rozwinąć, mam jedno menu rozwijane w arkuszu 7, które znajduje się w komórce B7 i to samo menu rozwijane w arkuszu 6 w komórce B2.

Dziękuję
Elaine
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć E,
Poniższy kod VBA może pomóc.
Tutaj biorę Sheet6 jako główny arkusz, kliknij prawym przyciskiem myszy kartę arkusza, wybierz Wyświetl kod z menu po kliknięciu prawym przyciskiem myszy, a następnie skopiuj następujący kod w oknie Sheet6 (Kod). Po wybraniu dowolnej pozycji z listy rozwijanej w B2 arkusza 6, lista rozwijana w B7 arkusza 7 zostanie zsynchronizowana tak, aby zawierała tę samą wybraną pozycję.

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
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć Kryształowo,

Dziękuję bardzo za odpowiedź, Twój kod zadziałał! Mam komórkę tuż pod b2 i b7, b3 i b8, które muszą mieć tę samą funkcję. Próbowałem przepisać twój kod, jak pokazano poniżej, ale to nie zadziałało. To spowodowało zmianę b7 zamiast b8, gdy zmieniłem b3. Czy mógłbyś określić, co robię źle?

Dziękuję bardzo!

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
Ten komentarz został zminimalizowany przez moderatora na stronie
Cześć E,
Coś jest nie tak z kodem VBA, na który odpowiedziałem powyżej.
W przypadku nowego pytania, o którym wspomniałeś, wypróbuj następujący kod.

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
Ten komentarz został zminimalizowany przez moderatora na stronie
Kryształ,

Dziękuję bardzo za odpowiedź, to zadziałało! Jak mogę zmodyfikować kod, aby dodać kolejną komórkę w tym samym arkuszu 6, B3, która również musiała być zsynchronizowana z B8 w arkuszu 7? Próbowałem to zmodyfikować poniżej, jednak kończy się to umieszczeniem zawartości B3 na arkuszu 6 w B7 na arkuszu 7 zamiast B8.


Prywatny Sub Worksheet_Change (ByVal Target As Range)
'Aktualizowany przez Extendoffice 20221025
Dim tSheet1 jako arkusz
Dim tRange1 jako zakres
Dim tRange2 jako zakres
Dim xRangeStr1 jako ciąg
Dim xRangeStr2 jako ciąg
On Error Resume Next
Jeśli Target.Count > 1, to wyjdź z Sub

xRangeStr1 = "B2"
xRangeStr2 = "B3"

Ustaw tRange1 = Zakres("B7")
Jeśli nie tRange1 to nic, to
xRangeStr1 = tRange1.Adres
Application.EnableEvents = Fałsz
Ustaw tSheet1 = ActiveWorkbook.Worksheets("Arkusz7")
tSheet1.Range(xRangeStr1).Value = Target.Value
Application.EnableEvents = True
End If

Ustaw tRange2 = Zakres("B8")
Jeśli nie tRange2 to nic, to
xRangeStr2 = tRange2.Adres
Application.EnableEvents = Fałsz
Ustaw tSheet1 = ActiveWorkbook.Worksheets("Arkusz7")
tSheet1.Range(xRangeStr2).Value = Target.Value
Application.EnableEvents = True
End If

End Sub
Nie ma tu jeszcze żadnych komentarzy
Zostaw swój komentarz
Publikowanie jako gość
×
Oceń ten post:
0   Postacie
Sugerowane lokalizacje

Bądż na bieżąco

Prawa autorskie © 2009 - www.extendoffice.com. | Wszelkie prawa zastrzeżone. Zasilany przez ExtendOffice, | Mapa strony
Microsoft i logo Office są znakami towarowymi lub zastrzeżonymi znakami towarowymi Microsoft Corporation w Stanach Zjednoczonych i / lub innych krajach.
Chronione przez Sectigo SSL