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

Jak synchronizovat rozevírací seznamy ve více listech v aplikaci Excel?

Předpokládejme, že máte rozevírací seznamy na několika listech v sešitu, které obsahují přesně stejné rozevírací položky. Nyní chcete synchronizovat rozevírací seznamy napříč listy tak, že jakmile vyberete položku z rozevíracího seznamu v jednom listu, rozevírací seznamy v ostatních listech se automaticky synchronizují se stejným výběrem. Tento článek poskytuje kód VBA, který vám pomůže tento problém vyřešit.

Synchronizujte rozevírací seznamy ve více listech s kódem VBA


Synchronizujte rozevírací seznamy ve více listech s kódem VBA

Například rozevírací seznamy jsou v pěti pojmenovaných listech List1, List2, ..., List5, Chcete-li synchronizovat rozevírací seznamy v jiných listech podle rozevíracího výběru v Listu1, použijte k tomu následující kód VBA.

1. Otevřete List1, klepněte pravým tlačítkem na záložku listu a vyberte Zobrazit kód z nabídky pravým tlačítkem myši.

2. V Microsoft Visual Basic pro aplikace okno, vložte následující kód VBA do List1 (kód) okno.

Kód VBA: Synchronizujte rozevírací seznam ve více listech

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

Poznámky:

1) V kódu, A2: A11 je rozsah obsahující rozevírací seznam. Ujistěte se, že všechny rozevírací seznamy jsou v různých listech ve stejném rozsahu.
2) List2, List3, List4 a Sheet5 jsou listy, které obsahují rozevírací seznamy, které chcete synchronizovat na základě rozevíracího seznamu v List1;
3) Chcete-li do kódu přidat další listy, přidejte následující dva řádky před řádek „Application.EnableEvents = True“, poté změňte název listu „Sheet5“ na jméno, které potřebujete.
Nastavit tSheet1 = ActiveWorkbook.Worksheets("Sheet5")
tSheet1.Range(xRangeStr).Value = Target.Value

3. zmáčkni Další + Q klávesy pro zavření Microsoft Visual Basic pro aplikace okno.

Od této chvíle, když vyberete položku z rozevíracího seznamu v List1, rozevírací seznamy v určených listech budou automaticky synchronizovány, aby měly stejný výběr. Podívejte se na níže uvedené demo.


Demo: Synchronizace rozevíracích seznamů ve více listech v aplikaci Excel


Nejlepší kancelářské nástroje produktivity

Kutools pro Excel řeší většinu vašich problémů a zvyšuje vaši produktivitu o 80%

  • Opakované použití: Rychle vložte složité vzorce, grafy a cokoli, co jste dříve používali; Šifrovat buňky s heslem; Vytvořte seznam adresátů a posílat e-maily ...
  • Super Formula Bar (snadno upravit více řádků textu a vzorce); Rozložení pro čtení (snadno číst a upravovat velké množství buněk); Vložit do filtrovaného rozsahu...
  • Sloučit buňky / řádky / sloupce bez ztráty dat; Rozdělit obsah buněk; Zkombinujte duplicitní řádky / sloupce... Zabraňte duplicitním buňkám; Porovnat rozsahy...
  • Vyberte možnost Duplikovat nebo Jedinečný Řádky; Vyberte prázdné řádky (všechny buňky jsou prázdné); Super hledání a fuzzy hledání v mnoha sešitech; Náhodný výběr ...
  • Přesná kopie Více buněk beze změny odkazu na vzorec; Automaticky vytvářet reference do více listů; Vložte odrážky, Zaškrtávací políčka a další ...
  • Extrahujte text, Přidat text, Odebrat podle pozice, Odebrat mezeru; Vytváření a tisk mezisoučtů stránkování; Převod mezi obsahem buněk a komentáři...
  • Super filtr (uložit a použít schémata filtrů na jiné listy); Rozšířené řazení podle měsíce / týdne / dne, frekvence a dalších; Speciální filtr tučnou kurzívou ...
  • Kombinujte sešity a pracovní listy; Sloučit tabulky na základě klíčových sloupců; Rozdělte data do více listů; Dávkový převod xls, xlsx a PDF...
  • Více než 300 výkonných funkcí. Podporuje Office / Excel 2007-2021 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Plné funkce 30denní bezplatná zkušební verze. 60denní záruka vrácení peněz.
karta kte 201905

Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50%a snižuje stovky kliknutí myší každý den!
officetab dno
Komentáře (5)
Zatím žádné hodnocení. Buďte první, kdo ohodnotí!
Tento komentář byl moderátorem webu minimalizován
Dobrý den,

Jak to mohu udělat, pokud jsou mé rozbalovací nabídky v různých rozsazích? Pro upřesnění mám jeden rozevírací seznam na listu 7, který je v buňce B7, a stejný rozevírací seznam na listu 6 v buňce B2.

Děkuji,
Elaine
Tento komentář byl moderátorem webu minimalizován
Ahoj E,
Pomoci může následující kód VBA.
Zde beru Sheet6 jako hlavní list, klikněte pravým tlačítkem na záložku listu, z nabídky pravým tlačítkem vyberte Zobrazit kód a poté zkopírujte následující kód do okna Sheet6 (Code). Když vyberete libovolnou položku z rozevíracího seznamu v B2 listu 6, rozevírací seznam v B7 listu 7 bude cynchronizován tak, aby měl stejnou vybranou položku.

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
Tento komentář byl moderátorem webu minimalizován
Ahoj Crystal,

Děkuji mnohokrát za odpověď, váš kód funguje! Mám buňku přímo pod b2 a b7, b3 a b8, které musí mít stejnou funkci. Pokusil jsem se přepsat váš kód, jak je uvedeno níže, ale nefungovalo to. Když jsem změnil b7, způsobilo to změnu b8 místo b3. Dokážete rozpoznat, co dělám špatně?

Děkuji moc!

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
Tento komentář byl moderátorem webu minimalizován
Ahoj E,
S kódem VBA, na který jsem vám odpověděl výše, je něco špatně.
Pro novou otázku, kterou jste zmínili, zkuste následující kód.

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
Tento komentář byl moderátorem webu minimalizován
Krystal,

Moc děkuji za odpověď, povedlo se! Jak bych mohl upravit kód a přidat další buňku na stejný list 6, B3, který také potřeboval synchronizovat s B8 na listu 7? Pokusil jsem se to upravit níže, ale skončí to tak, že se obsah B3 vloží na list 6 v B7 na list 7 místo B8.


Soukromá dílčí tabulka_Změna (ByVal Target As Range)
'Aktualizováno Extendoffice 20221025
Dim tSheet1 As Worksheet
Dim tRange1 As Range
Dim tRange2 As Range
Dim xRangeStr1 jako řetězec
Dim xRangeStr2 jako řetězec
On Error Resume Next
Pokud Target.Count > 1, pak Exit Sub

xRangeStr1 = "B2"
xRangeStr2 = "B3"

Nastavit tRange1 = Range("B7")
If Not tRange1 Is Nothing Then
xRangeStr1 = tRange1.Address
Application.EnableEvents = False
Nastavit tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
tSheet1.Range(xRangeStr1).Value = Target.Value
Application.EnableEvents = True
End If

Nastavit tRange2 = Range("B8")
If Not tRange2 Is Nothing Then
xRangeStr2 = tRange2.Address
Application.EnableEvents = False
Nastavit tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
tSheet1.Range(xRangeStr2).Value = Target.Value
Application.EnableEvents = True
End If

End Sub
Zatím zde nejsou žádné komentáře
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění

Sociální sítě

Copyright © 2009 - www.extendoffice.com. | Všechna práva vyhrazena. Poháněno ExtendOffice. | |. | Sitemap
Microsoft a logo Office jsou ochranné známky nebo registrované ochranné známky společnosti Microsoft Corporation ve Spojených státech a / nebo jiných zemích.
Chráněno Sectigo SSL