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

Πώς να συγχρονίσετε τις αναπτυσσόμενες λίστες σε πολλά φύλλα εργασίας στο 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” στο όνομα που χρειάζεστε.
Set tSheet1 = ActiveWorkbook.Worksheets("Φύλλο5")
tSheet1.Range(xRangeStr).Value = Target.Value

3. Πάτα το άλλος + Q πλήκτρα για να κλείσετε το Microsoft Visual Basic για εφαρμογές παράθυρο.

Από εδώ και στο εξής, όταν επιλέγετε ένα στοιχείο από την αναπτυσσόμενη λίστα στο Φύλλο 1, οι αναπτυσσόμενες λίστες στα καθορισμένα φύλλα εργασίας θα συγχρονιστούν αυτόματα για να έχουν την ίδια επιλογή. Δείτε το παρακάτω demo.


Επίδειξη: Συγχρονισμός αναπτυσσόμενων λιστών σε πολλά φύλλα εργασίας στο Excel


Τα καλύτερα εργαλεία παραγωγικότητας του Office

Το Kutools για Excel λύνει τα περισσότερα από τα προβλήματά σας και αυξάνει την παραγωγικότητά σας κατά 80%

  • Επαναχρησιμοποίηση: Εισαγάγετε γρήγορα σύνθετοι τύποι, γραφήματα και οτιδήποτε έχετε χρησιμοποιήσει στο παρελθόν. Κρυπτογράφηση κυττάρων με κωδικό πρόσβασης Δημιουργία λίστας αλληλογραφίας και στείλτε email ...
  • Super Formula Bar (επεξεργαστείτε εύκολα πολλές γραμμές κειμένου και τύπου). Διάταξη ανάγνωσης (εύκολη ανάγνωση και επεξεργασία μεγάλου αριθμού κελιών). Επικόλληση σε φιλτραρισμένο εύρος...
  • Συγχώνευση κελιών / σειρών / στηλών χωρίς απώλεια δεδομένων · Περιεχόμενο διαχωρισμού κελιών Συνδυάστε διπλές σειρές / στήλες... Αποτροπή διπλών κυττάρων; Συγκρίνετε τα εύρη...
  • Επιλέξτε Διπλότυπο ή Μοναδικό Σειρές; Επιλέξτε Κενές σειρές (όλα τα κελιά είναι κενά). Σούπερ εύρεση και ασαφής εύρεση σε πολλά βιβλία εργασίας. Τυχαία επιλογή ...
  • Ακριβές αντίγραφο Πολλαπλά κελιά χωρίς αλλαγή της αναφοράς τύπου. Αυτόματη δημιουργία αναφορών σε πολλαπλά φύλλα? Εισαγωγή κουκκίδων, Πλαίσια ελέγχου και άλλα ...
  • Εξαγωγή κειμένου, Προσθήκη κειμένου, Κατάργηση κατά θέση, Αφαιρέστε το διάστημα; Δημιουργία και εκτύπωση υποσύνολων σελιδοποίησης. Μετατροπή περιεχομένου και σχολίων μεταξύ κελιών...
  • Σούπερ φίλτρο (αποθηκεύστε και εφαρμόστε σχήματα φίλτρων σε άλλα φύλλα). Προηγμένη ταξινόμηση ανά μήνα / εβδομάδα / ημέρα, συχνότητα και άλλα. Ειδικό φίλτρο με έντονη, πλάγια ...
  • Συνδυάστε βιβλία εργασίας και φύλλα εργασίας; Συγχώνευση πινάκων βάσει βασικών στηλών. Διαχωρίστε τα δεδομένα σε πολλά φύλλα; Μαζική μετατροπή xls, xlsx και PDF...
  • Περισσότερα από 300 ισχυρά χαρακτηριστικά. Υποστηρίζει Office / Excel 2007-2021 και 365. Υποστηρίζει όλες τις γλώσσες. Εύκολη ανάπτυξη στην επιχείρηση ή τον οργανισμό σας. Πλήρεις δυνατότητες δωρεάν δοκιμής 30 ημερών. Εγγύηση επιστροφής χρημάτων 60 ημερών.
kte καρτέλα 201905

Το Office Tab φέρνει τη διεπαφή με καρτέλες στο Office και κάνει την εργασία σας πολύ πιο εύκολη

  • Ενεργοποίηση επεξεργασίας και ανάγνωσης καρτελών σε Word, Excel, PowerPoint, Publisher, Access, Visio και Project.
  • Ανοίξτε και δημιουργήστε πολλά έγγραφα σε νέες καρτέλες του ίδιου παραθύρου και όχι σε νέα παράθυρα.
  • Αυξάνει την παραγωγικότητά σας κατά 50% και μειώνει εκατοντάδες κλικ του ποντικιού για εσάς κάθε μέρα!
κάτω μέρος γραφείου
Σχόλια (5)
Δεν υπάρχουν ακόμη βαθμολογίες. Γίνε ο πρώτος που θα αξιολογήσετε!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας,

Πώς μπορώ να το κάνω αυτό εάν τα αναπτυσσόμενα μενού βρίσκονται σε διαφορετικά εύρη; Για να το εξηγήσω, έχω ένα αναπτυσσόμενο μενού στο φύλλο 7 που βρίσκεται στο κελί Β7 και το ίδιο αναπτυσσόμενο μενού στο φύλλο 6 στο κελί Β2.

Ευχαριστώ,
Elaine
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια Ε,
Ο παρακάτω κώδικας VBA μπορεί να βοηθήσει.
Εδώ παίρνω το Sheet6 ως κύριο φύλλο εργασίας, κάνω δεξί κλικ στην καρτέλα του φύλλου, επιλέγω Προβολή κώδικα από το μενού με το δεξί κλικ και, στη συνέχεια, αντιγράφω τον ακόλουθο κώδικα στο παράθυρο Φύλλο6 (Κωδικός). Όταν επιλέγετε οποιοδήποτε στοιχείο από την αναπτυσσόμενη λίστα στο Β2 του Φύλλου6, η αναπτυσσόμενη λίστα στο Β7 του Φύλλου 7 θα συγχρονίζεται ώστε να έχει το ίδιο επιλεγμένο στοιχείο.

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
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Crystal,

Σας ευχαριστώ πολύ για την απάντησή σας, ο κωδικός σας λειτούργησε! Έχω ένα κελί ακριβώς κάτω από τα 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
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια Ε,
Κάτι δεν πάει καλά με τον κωδικό 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
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Κρύσταλλο,

Σας ευχαριστώ πολύ για την απάντησή σας, αυτό λειτούργησε! Πώς θα μπορούσα να τροποποιήσω τον κώδικα για να προσθέσω ένα άλλο κελί στο ίδιο φύλλο 6, B3 που έπρεπε επίσης να συγχρονιστεί με το B8 στο φύλλο 7; Προσπάθησα να το τροποποιήσω παρακάτω, ωστόσο καταλήγει να βάζει τα περιεχόμενα του Β3 στο φύλλο 6 στο Β7 στο φύλλο 7 αντί για το Β8.


Προσωπικό φύλλο εργασίας Sub_change (ByVal Target As Range)
«Ενημερώθηκε από Extendoffice 20221025
Dim tSheet1 ως φύλλο εργασίας
Dim tRange1 As Range
Dim tRange2 As Range
Dim xRangeStr1 ως συμβολοσειρά
Dim xRangeStr2 ως συμβολοσειρά
On Error Συνέχιση Επόμενη
Αν Target.Count > 1 Στη συνέχεια, βγείτε από το Sub

xRangeStr1 = "B2"
xRangeStr2 = "B3"

Ορισμός tRange1 = Εύρος ("B7")
Αν δεν είναι το tRange1 είναι τίποτα τότε
xRangeStr1 = tRange1.Διεύθυνση
Application.EnableEvents = False
Set tSheet1 = ActiveWorkbook.Worksheets("Φύλλο7")
tSheet1.Range(xRangeStr1).Value = Target.Value
Application.EnableEvents = True
End If

Ορισμός tRange2 = Εύρος ("B8")
Αν δεν είναι το tRange2 είναι τίποτα τότε
xRangeStr2 = tRange2.Διεύθυνση
Application.EnableEvents = False
Set tSheet1 = ActiveWorkbook.Worksheets("Φύλλο7")
tSheet1.Range(xRangeStr2).Value = Target.Value
Application.EnableEvents = True
End If

Sub End
Δεν υπάρχουν σχόλια δημοσιεύτηκε ακόμα
Αφήστε τα σχόλιά σας
Δημοσίευση ως επισκέπτης
×
Αξιολογήστε αυτήν την ανάρτηση:
0   Χαρακτήρες
Προτεινόμενες τοποθεσίες

Ακολουθησε μας

Πνευματικά δικαιώματα © 2009 - www.extendoffice.com. | Ολα τα δικαιώματα διατηρούνται. Τροφοδοτείται από ExtendOffice. | Sitemap
Το Microsoft και το λογότυπο του Office είναι εμπορικά σήματα ή σήματα κατατεθέντα της Microsoft Corporation στις Ηνωμένες Πολιτείες ή / και σε άλλες χώρες.
Προστατεύεται από το Sectigo SSL