Kako sinhronizirati spustne sezname v več delovnih listih v Excelu?

Recimo, da imate spustne sezname na več delovnih listih v delovnem zvezku, ki vsebujejo popolnoma enake spustne elemente. Zdaj želite sinhronizirati spustne sezname med delovnimi listi, tako da ko izberete element s spustnega seznama na enem delovnem listu, se spustni seznami na drugih delovnih listih samodejno sinhronizirajo z isto izbiro. Ta članek ponuja kodo VBA, ki vam pomaga rešiti to težavo.

Sinhronizirajte spustne sezname v več delovnih listih s kodo VBA

Sinhronizirajte spustne sezname v več delovnih listih s kodo VBA

Na primer, spustni seznami so v petih imenovanih delovnih listih List1, List2, ..., list5, če želite sinhronizirati spustne sezname v drugih delovnih listih glede na spustni izbor v Sheet1, uporabite naslednjo kodo VBA, da to storite.

1. Odprite Sheet1, z desno miškino tipko kliknite jeziček lista in izberite Ogled kode v meniju z desno tipko miške kliknite.

2. V Ljubljani Microsoft Visual Basic za aplikacije prilepite naslednjo kodo VBA v okno List1 (koda) okno.

Koda VBA: Sinhronizirajte spustni seznam v več delovnih listih

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

Opombe:

1) V kodi, A2: A11 je obseg, ki vsebuje spustni seznam. Prepričajte se, da so vsi spustni seznami v istem obsegu na različnih delovnih listih.

2) List2, List3, List4 in Sheet5 so delovni listi, ki vsebujejo spustne sezname, ki jih želite sinhronizirati na podlagi spustnega seznama v Listu1;

3) Če želite dodati več delovnih listov v kodo, dodajte naslednji dve vrstici pred vrstico "Aplikacija EnableEvents = True«, nato spremenite ime lista »Sheet5” na ime, ki ga potrebujete.

Nastavite tSheet1 = ActiveWorkbook.Worksheets("Sheet5")

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

3. Pritisnite druga + Q tipke za zapiranje Microsoft Visual Basic za aplikacije okno.

Od zdaj naprej, ko izberete predmet s spustnega seznama v list1, spustni seznami v določenih delovnih listih bodo samodejno sinhronizirani, da bodo imeli enak izbor. Oglejte si spodnjo predstavitev.

Predstavitev: Sinhronizacija spustnih seznamov v več delovnih listih v Excelu

Najboljša orodja za pisarniško produktivnost

Kutools za Excel rešuje večino vaših težav in poveča vašo produktivnost za 80%

Ponovna uporaba: Hitro vstavite zapletene formule, grafikoni in vse, kar ste že uporabljali; Šifriraj celice z geslom; Ustvari poštni seznam in pošiljanje e-pošte ...
Vrstica Super Formula (enostavno urejanje več vrstic besedila in formule); Bralna postavitev (enostavno branje in urejanje velikega števila celic); Prilepite v filtrirani obseg...
Združi celice / vrstice / stolpce brez izgube podatkov; Vsebina razdeljenih celic; Združi podvojene vrstice / stolpce... prepreči podvojene celice; Primerjaj obsege...
Izberite Duplicate ali Unique Vrstice; Izberite prazne vrstice (vse celice so prazne); Super Find in Fuzzy Find v mnogih delovnih zvezkih; Naključna izbira ...
Natančna kopija Več celic brez spreminjanja sklica formule; Samodejno ustvarjanje referenc na več listov; Vstavi oznake, Potrditvena polja in še več ...
Izvleček besedila, Dodaj besedilo, Odstrani po položaju, Odstrani presledek; Ustvari in natisni vmesne seštevke strani Pretvarjanje med vsebino celic in komentarji...
Super filter (shranite in uporabite sheme filtrov za druge liste); Napredno razvrščanje glede na mesec / teden / dan, pogostost in drugo; Poseben filter s krepko, ležeče ...
Združite delovne zvezke in delovne liste; Spoji tabele na podlagi ključnih stolpcev; Razdelite podatke na več listov; Paketna pretvorba xls, xlsx in PDF...
Več kot 300 zmogljivih funkcij. Podpira Office / Excel 2007-2021 in 365. Podpira vse jezike. Enostavna uvedba v vašem podjetju ali organizaciji. 30-dnevna brezplačna preizkusna različica vseh funkcij. 60-dnevna garancija vračila denarja.

Preberite več ... Brezplačen prenos... Nakup ...

Kartica Office prinaša vmesnik z zavihki v Office in poenostavi vaše delo

Omogočite urejanje in branje z zavihki v Wordu, Excelu, PowerPointu, Publisher, Access, Visio in Project.
Odprite in ustvarite več dokumentov v novih zavihkih istega okna in ne v novih oknih.
Poveča vašo produktivnost za 50%in vsak dan zmanjša na stotine klikov miške za vas!

Preberite več ... Brezplačen prenos... Nakup ...

Komentarji (5)

Ocene še ni. Bodite prvi in ocenite!

pred približno tremi meseci

#40764

Ta komentar je moderator na spletnem mestu minimiziral

Hi,

Kako lahko to storim, če so moji spustni meniji v različnih obsegih? Če pojasnim, imam en spustni meni na listu 7, ki je v celici B7, in isti spustni meni na listu 6 v celici B2.

Hvala,
Elaine

Odgovori

kristal E

pred približno tremi meseci

#40859

Ta komentar je moderator na spletnem mestu minimiziral

Živjo E,
Naslednja koda VBA vam lahko pomaga.
Tukaj vzamem Sheet6 kot glavni delovni list, z desno miškino tipko kliknite zavihek lista, v meniju z desnim klikom izberite Ogled kode, nato kopirajte naslednjo kodo v okno Sheet6 (Koda). Ko izberete kateri koli element s spustnega seznama v B2 lista 6, bo spustni seznam v B7 lista 7 sinhroniziran tako, da bo imel isti izbrani element.

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

Odgovori

poročilo

E kristal

pred približno tremi meseci

#40915

Ta komentar je moderator na spletnem mestu minimiziral

Živjo Crystal,

Najlepša hvala za vaš odgovor, vaša koda je delovala! Imam celico tik pod b2 in b7, b3 oziroma b8, ki morajo imeti enako funkcijo. Poskušal sem prepisati vašo kodo, kot je prikazano spodaj, vendar to ni delovalo. Povzročilo je spremembo b7 namesto b8, ko sem spremenil b3. Ali lahko ugotovite, kaj delam narobe?

Najlepša hvala!

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

Odgovori

kristal E

pred približno tremi meseci

#40991

Ta komentar je moderator na spletnem mestu minimiziral

Živjo E,
Nekaj je narobe s kodo VBA, na katero sem vam odgovoril zgoraj.
Za novo vprašanje, ki ste ga omenili, poskusite z naslednjo kodo.

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

Odgovori

poročilo

pred približno tremi meseci

#40890

Ta komentar je moderator na spletnem mestu minimiziral

kristal,

Najlepša hvala za vaš odgovor, to je delovalo! Kako bi lahko spremenil kodo, da dodam še eno celico na isti list 6, B3, ki jo je bilo prav tako treba sinhronizirati z B8 na listu 7? Poskušal sem ga spremeniti spodaj, vendar na koncu postavi vsebino B3 na list 6 in B7 na list 7 namesto B8.

Zasebni poddelovni list_Spremeni (ByVal Target As Range)
'Posodobil Extendoffice 20221025
Dim tSheet1 Kot delovni list
Dim tRange1 Kot obseg
Dim tRange2 Kot obseg
Dim xRangeStr1 kot niz
Dim xRangeStr2 kot niz
On Error Resume Next
Če je Target.Count > 1, potem zapustite sub

xRangeStr1 = "B2"
xRangeStr2 = "B3"

Nastavite tRange1 = Range("B7")
Če ni tRange1, potem ni nič
xRangeStr1 = tRange1.Address
Application.EnableEvents = False
Nastavite tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
tSheet1.Range(xRangeStr1).Vrednost = Target.Value
Aplikacija EnableEvents = True
Konec Če

Nastavite tRange2 = Range("B8")
Če ni tRange2, potem ni nič
xRangeStr2 = tRange2.Address
Application.EnableEvents = False
Nastavite tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
tSheet1.Range(xRangeStr2).Vrednost = Target.Value
Aplikacija EnableEvents = True
Konec Če

End Sub

Odgovori

Tu še ni objavljenih komentarjev

Pustite vaše komentarje

Objava kot gost

Prijava

Ime (obvezno)

E-pošta (obvezno)

Ocenite to objavo:

Ponastavi

0 Znaki

Strinjam se pogoji in stanje