Μετάβαση στο κύριο περιεχόμενο

Επιλέξτε πολλά στοιχεία στην αναπτυσσόμενη λίστα του Excel - πλήρης οδηγός

Οι αναπτυσσόμενες λίστες του Excel είναι ένα φανταστικό εργαλείο για τη διασφάλιση της συνέπειας των δεδομένων και της ευκολίας εισαγωγής. Ωστόσο, από προεπιλογή, σας περιορίζουν στην επιλογή μόνο ενός στοιχείου. Τι γίνεται όμως αν χρειαστεί να επιλέξετε πολλά στοιχεία από την ίδια αναπτυσσόμενη λίστα; Αυτός ο περιεκτικός οδηγός θα διερευνήσει μεθόδους για την ενεργοποίηση πολλαπλών επιλογών σε αναπτυσσόμενες λίστες του Excel, τη διαχείριση των διπλότυπων, τον ορισμό προσαρμοσμένων διαχωριστικών και τον καθορισμό του εύρους αυτών των λιστών.

Άκρο: Πριν εφαρμόσετε τις ακόλουθες μεθόδους, βεβαιωθείτε ότι έχετε δημιουργήσει εκ των προτέρων αναπτυσσόμενες λίστες στα φύλλα εργασίας σας. Εάν θέλετε να μάθετε πώς να δημιουργείτε αναπτυσσόμενες λίστες επικύρωσης δεδομένων, ακολουθήστε τις οδηγίες σε αυτό το άρθρο: Πώς να δημιουργήσετε αναπτυσσόμενες λίστες επικύρωσης δεδομένων στο Excel.

Ενεργοποίηση πολλαπλών επιλογών στην αναπτυσσόμενη λίστα

Αυτή η ενότητα παρέχει δύο μεθόδους για να σας βοηθήσει να ενεργοποιήσετε πολλαπλές επιλογές στην αναπτυσσόμενη λίστα στο Excel.

Χρήση κώδικα VBA

Για να επιτρέψετε πολλαπλές επιλογές στην αναπτυσσόμενη λίστα, μπορείτε να χρησιμοποιήσετε Visual Basic για εφαρμογές (VBA) στο Excel. Το σενάριο μπορεί να τροποποιήσει τη συμπεριφορά μιας αναπτυσσόμενης λίστας για να την κάνει λίστα πολλαπλών επιλογών. Παρακαλώ κάντε το εξής.

Βήμα 1: Ανοίξτε το πρόγραμμα επεξεργασίας φύλλου (Κώδικας).
  1. Ανοίξτε το φύλλο εργασίας που περιέχει την αναπτυσσόμενη λίστα για την οποία θέλετε να ενεργοποιήσετε την πολλαπλή επιλογή.
  2. Κάντε δεξί κλικ στην καρτέλα του φύλλου και επιλέξτε Προβολή κωδικού από το μενού περιβάλλοντος.
Βήμα 2: Χρησιμοποιήστε τον κώδικα VBA

Τώρα αντιγράψτε τον ακόλουθο κώδικα VBA και επικολλήστε τον στο παράθυρο ανοίγματος του φύλλου (Κωδικός).

Κώδικας VBA: Ενεργοποίηση πολλαπλών επιλογών στην αναπτυσσόμενη λίστα του Excel.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20240118
    Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    Dim delimiter As String
    Dim TargetRange As Range

    Set TargetRange = Me.UsedRange ' Users can change target range here
    delimiter = ", " ' Users can change the delimiter here

    If Target.Count > 1 Or Intersect(Target, TargetRange) Is Nothing Then Exit Sub
    On Error Resume Next
    Set xRng = TargetRange.SpecialCells(xlCellTypeAllValidation)
    If xRng Is Nothing Then Exit Sub
    Application.EnableEvents = False

    xValue2 = Target.Value
    Application.Undo
    xValue1 = Target.Value
    Target.Value = xValue2
    If xValue1 <> "" And xValue2 <> "" Then
        If Not (xValue1 = xValue2 Or _
                InStr(1, xValue1, delimiter & xValue2) > 0 Or _
                InStr(1, xValue1, xValue2 & delimiter) > 0) Then
            Target.Value = xValue1 & delimiter & xValue2
        Else
            Target.Value = xValue1
        End If
    End If

    Application.EnableEvents = True
    On Error GoTo 0
End Sub

Αποτέλεσμα

Όταν επιστρέψετε στο φύλλο εργασίας, η αναπτυσσόμενη λίστα θα σας επιτρέψει να επιλέξετε πολλές επιλογές, δείτε την παρακάτω επίδειξη:

Notes:
Ο παραπάνω κωδικός VBA:
  • Ισχύει για όλες τις αναπτυσσόμενες λίστες επικύρωσης δεδομένων στο τρέχον φύλλο εργασίας, τόσο σε υπάρχουσες όσο και σε αυτές που θα δημιουργηθούν στο μέλλον.
  • Σας εμποδίζει να επιλέξετε το ίδιο στοιχείο περισσότερες από μία φορές σε κάθε αναπτυσσόμενη λίστα.
  • Χρησιμοποιεί κόμμα ως διαχωριστικό για τα επιλεγμένα στοιχεία. Για να χρησιμοποιήσετε άλλους οριοθέτες, παρακαλούμε δείτε αυτήν την ενότητα για να αλλάξετε το διαχωριστικό.

Χρήση Kutools για Excel με μερικά κλικ

Εάν δεν αισθάνεστε άνετα με το VBA, μια ευκολότερη εναλλακτική είναι Kutools για Excel's Αναδυόμενη λίστα πολλαπλών επιλογών χαρακτηριστικό. Αυτό το φιλικό προς το χρήστη εργαλείο απλοποιεί την ενεργοποίηση πολλαπλών επιλογών σε αναπτυσσόμενες λίστες, προσφέροντας διάφορα πεδία, όπως ένα συγκεκριμένο εύρος, το τρέχον φύλλο εργασίας, ολόκληρο το βιβλίο εργασίας ή όλα τα ανοιχτά βιβλία εργασίας. Επιπλέον, σας επιτρέπει να προσαρμόσετε το διαχωριστικό και να διαχειρίζεστε τα αντίγραφα χωρίς κόπο για να καλύψετε τις διαφορετικές σας ανάγκες.

Μετά το εγκατάσταση Kutools για Excel, μεταβείτε στο Kutools καρτέλα, επιλέξτε Αναπτυσσόμενη λίστα > Αναδυόμενη λίστα πολλαπλών επιλογών. Στη συνέχεια, πρέπει να ρυθμίσετε τις παραμέτρους ως εξής.

  1. Καθορίστε πού θέλετε να εφαρμόσετε αυτήν τη δυνατότητα στο Ορίστε το πεδίο εφαρμογής τμήμα.
  2. Καθορίστε το διαχωριστικό για τα επιλεγμένα στοιχεία σε ένα κελί.
  3. Αποφασίστε την κατεύθυνση του κειμένου.
  4. Πατήστε OK.
Αποτέλεσμα

Τώρα, όταν κάνετε κλικ σε ένα κελί με μια αναπτυσσόμενη λίστα, ένα πλαίσιο λίστας θα εμφανιστεί δίπλα του. Απλώς κάντε κλικ στο κουμπί "+" δίπλα στα στοιχεία για να τα προσθέσετε στο αναπτυσσόμενο κελί και κάντε κλικ στο κουμπί "-" για να αφαιρέσετε τυχόν στοιχεία που δεν θέλετε. Δείτε το demo παρακάτω:

Note: Για να εφαρμόσετε αυτήν τη δυνατότητα, παρακαλούμε κατεβάστε και εγκαταστήστε το Kutools για Excel πρώτη.

Περισσότερες λειτουργίες για την αναπτυσσόμενη λίστα πολλαπλών επιλογών

Αυτή η ενότητα συλλέγει τα διαφορετικά σενάρια που μπορεί να απαιτούνται κατά την ενεργοποίηση πολλαπλών επιλογών στην αναπτυσσόμενη λίστα Επικύρωση δεδομένων.


Επιτρέπονται διπλότυπα στοιχεία στην αναπτυσσόμενη λίστα

Τα διπλότυπα μπορεί να είναι πρόβλημα όταν επιτρέπονται πολλαπλές επιλογές σε μια αναπτυσσόμενη λίστα. Ο παραπάνω κώδικας VBA δεν επιτρέπει διπλότυπα στοιχεία στην αναπτυσσόμενη λίστα. Εάν πρέπει να διατηρήσετε διπλότυπα στοιχεία, δοκιμάστε τον κώδικα VBA σε αυτήν την ενότητα.

Κωδικός VBA: Επιτρέπονται διπλότυπα στην αναπτυσσόμενη λίστα επικύρωσης δεδομένων

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20240118
    Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    Dim delimiter As String
    Dim TargetRange As Range

    Set TargetRange = Me.UsedRange ' Users can change target range here
    delimiter = ", " ' Users can change the delimiter here

    If Target.Count > 1 Or Intersect(Target, TargetRange) Is Nothing Then Exit Sub
    On Error Resume Next
    Set xRng = TargetRange.SpecialCells(xlCellTypeAllValidation)
    If xRng Is Nothing Then Exit Sub
    Application.EnableEvents = False

    xValue2 = Target.Value
    Application.Undo
    xValue1 = Target.Value
    Target.Value = xValue2
    If xValue1 <> "" And xValue2 <> "" Then
        Target.Value = xValue1 & delimiter & xValue2
    End If

    Application.EnableEvents = True
    On Error GoTo 0
End Sub
Αποτέλεσμα

Τώρα μπορείτε να επιλέξετε πολλά στοιχεία από τις αναπτυσσόμενες λίστες στο τρέχον φύλλο εργασίας. Για να επαναλάβετε ένα στοιχείο σε ένα κελί αναπτυσσόμενης λίστας, συνεχίστε να επιλέγετε αυτό το στοιχείο από τη λίστα. Δείτε στιγμιότυπο οθόνης:


Αφαίρεση τυχόν υπαρχόντων στοιχείων από την αναπτυσσόμενη λίστα

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

Κωδικός VBA: Καταργήστε τυχόν υπάρχοντα στοιχεία από το κελί της αναπτυσσόμενης λίστας

Private Sub Worksheet_Change(ByVal Target As Range)
    'Updated by Extendoffice 20240118
    Dim xRngDV As Range
    Dim TargetRange As Range
    Dim oldValue As String
    Dim newValue As String
    Dim delimiter As String
    Dim allValues As Variant
    Dim valueExists As Boolean
    Dim i As Long
    Dim cleanedValue As String

    Set TargetRange = Me.UsedRange ' Set your specific range here
    delimiter = ", " ' Set your desired delimiter here

    If Target.CountLarge > 1 Then Exit Sub

    ' Check if the change is within the specific range
    If Intersect(Target, TargetRange) Is Nothing Then Exit Sub

    On Error Resume Next
    Set xRngDV = Target.SpecialCells(xlCellTypeAllValidation)
    If xRngDV Is Nothing Or Target.Value = "" Then
        ' Skip if there's no data validation or if the cell is cleared
        Application.EnableEvents = True
        Exit Sub
    End If
    On Error GoTo 0

    If Not Intersect(Target, xRngDV) Is Nothing Then
        Application.EnableEvents = False
        newValue = Target.Value
        Application.Undo
        oldValue = Target.Value
        Target.Value = newValue

        ' Split the old value by delimiter and check if new value already exists
        allValues = Split(oldValue, delimiter)
        valueExists = False
        For i = LBound(allValues) To UBound(allValues)
            If Trim(allValues(i)) = newValue Then
                valueExists = True
                Exit For
            End If
        Next i

        ' Add or remove value based on its existence
        If valueExists Then
            ' Remove the value
            cleanedValue = ""
            For i = LBound(allValues) To UBound(allValues)
                If Trim(allValues(i)) <> newValue Then
                    If cleanedValue <> "" Then cleanedValue = cleanedValue & delimiter
                    cleanedValue = cleanedValue & Trim(allValues(i))
                End If
            Next i
            Target.Value = cleanedValue
        Else
            ' Add the value
            If oldValue <> "" Then
                Target.Value = oldValue & delimiter & newValue
            Else
                Target.Value = newValue
            End If
        End If

        Application.EnableEvents = True
    End If
End Sub
Αποτέλεσμα

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


Ρύθμιση προσαρμοσμένου διαχωριστικού

Ο οριοθέτης ορίζεται ως κόμμα στους παραπάνω κωδικούς VBA. Μπορείτε να τροποποιήσετε αυτήν τη μεταβλητή σε οποιονδήποτε προτιμώμενο χαρακτήρα για χρήση ως διαχωριστικό για τις επιλογές της αναπτυσσόμενης λίστας. Εδώ είναι πώς μπορείτε να κάνετε:

Όπως μπορείτε να δείτε ότι οι παραπάνω κωδικοί VBA έχουν όλοι την ακόλουθη γραμμή:

delimiter = ", "

Απλώς πρέπει να αλλάξετε το κόμμα σε οποιοδήποτε διαχωριστικό θέλετε. Για παράδειγμα, θέλετε να διαχωρίσετε τα στοιχεία με ερωτηματικό, αλλάξτε τη γραμμή σε:

delimiter = "; "
Σημείωση: Για να αλλάξετε τον οριοθέτη σε χαρακτήρα νέας γραμμής σε αυτούς τους κωδικούς VBA, αλλάξτε αυτήν τη γραμμή σε:
delimiter = vbNewLine

Ρύθμιση καθορισμένου εύρους

Οι παραπάνω κωδικοί VBA ισχύουν για όλες τις αναπτυσσόμενες λίστες στο τρέχον φύλλο εργασίας. Εάν θέλετε οι κωδικοί VBA να εφαρμόζονται μόνο σε ένα συγκεκριμένο εύρος αναπτυσσόμενων λιστών, μπορείτε να καθορίσετε το εύρος στον παραπάνω κώδικα VBA ως εξής.

Όπως μπορείτε να δείτε ότι οι παραπάνω κωδικοί VBA έχουν όλοι την ακόλουθη γραμμή:

Set TargetRange = Me.UsedRange

Απλά πρέπει να αλλάξετε τη γραμμή σε:

Set TargetRange = Me.Range("C2:C10")
Note: Εδώ C2: C10 είναι το εύρος που περιέχει την αναπτυσσόμενη λίστα που θέλετε να ορίσετε ως πολλαπλές επιλογές.

Εκτέλεση σε προστατευμένο φύλλο εργασίας

Φανταστείτε ότι έχετε προστατεύσει ένα φύλλο εργασίας με τον κωδικό πρόσβασης "123" και ορίστε τα κελιά της αναπτυσσόμενης λίστας σε "Unlocked" πριν από την ενεργοποίηση της προστασίας, διασφαλίζοντας έτσι ότι η λειτουργία πολλαπλής επιλογής παραμένει ενεργή μετά την προστασία. Ωστόσο, οι κωδικοί VBA που αναφέρονται παραπάνω δεν μπορούν να λειτουργήσουν σε αυτήν την περίπτωση και αυτή η ενότητα περιγράφει μια άλλη δέσμη ενεργειών VBA που έχει σχεδιαστεί ειδικά για να χειρίζεται λειτουργίες πολλαπλής επιλογής σε προστατευμένο φύλλο εργασίας.

Κώδικας VBA: Ενεργοποίηση πολλαπλής επιλογής στην αναπτυσσόμενη λίστα χωρίς διπλότυπα


Private Sub Worksheet_Change(ByVal Target As Range)
    'Updated by Extendoffice 20240118
    Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    Dim delimiter As String
    Dim TargetRange As Range
    Dim isProtected As Boolean
    Dim pswd As Variant

    Set TargetRange = Me.UsedRange ' Set your specific range here
    delimiter = ", " ' Users can change the delimiter here

    If Target.Count > 1 Or Intersect(Target, TargetRange) Is Nothing Then Exit Sub
    
    ' Check if sheet is protected
    isProtected = Me.ProtectContents
    If isProtected Then
        ' If protected, temporarily unprotect. Adjust or remove the password as needed.
        pswd = "yourPassword" ' Change or remove this as needed
        Me.Unprotect Password:=pswd
    End If

    On Error Resume Next
    Set xRng = TargetRange.SpecialCells(xlCellTypeAllValidation)
    If xRng Is Nothing Then
        If isProtected Then Me.Protect Password:=pswd
        Exit Sub
    End If
    Application.EnableEvents = False

    xValue2 = Target.Value
    Application.Undo
    xValue1 = Target.Value
    Target.Value = xValue2
    If xValue1 <> "" And xValue2 <> "" Then
        If Not (xValue1 = xValue2 Or _
                InStr(1, xValue1, delimiter & xValue2) > 0 Or _
                InStr(1, xValue1, xValue2 & delimiter) > 0) Then
            Target.Value = xValue1 & delimiter & xValue2
        Else
            Target.Value = xValue1
        End If
    End If

    Application.EnableEvents = True
    On Error GoTo 0

    ' Re-protect the sheet if it was protected
    If isProtected Then
        Me.Protect Password:=pswd
    End If
End Sub
Note: Στον κωδικό, φροντίστε να αντικαταστήσετε το "ο κωδικός σας” στη γραμμή pswd = "ο κωδικός σας" με τον πραγματικό κωδικό πρόσβασης που χρησιμοποιείτε για την προστασία του φύλλου εργασίας. Για παράδειγμα, εάν ο κωδικός πρόσβασής σας είναι "Abc123», τότε η γραμμή πρέπει να είναι pswd = "abc123".

Ενεργοποιώντας πολλαπλές επιλογές σε αναπτυσσόμενες λίστες του Excel, μπορείτε να βελτιώσετε σημαντικά τη λειτουργικότητα και την ευελιξία των φύλλων εργασίας σας. Είτε είστε άνετοι με την κωδικοποίηση VBA είτε προτιμάτε μια πιο απλή λύση όπως το Kutools, έχετε τώρα τη δυνατότητα να μετατρέψετε τις τυπικές αναπτυσσόμενες λίστες σας σε δυναμικά εργαλεία πολλαπλής επιλογής. Με αυτές τις δεξιότητες, είστε πλέον εξοπλισμένοι για να δημιουργήσετε πιο δυναμικά και φιλικά προς το χρήστη έγγραφα Excel. Για όσους επιθυμούν να εμβαθύνουν στις δυνατότητες του Excel, ο ιστότοπός μας μπορεί να υπερηφανεύεται για πληθώρα οδηγών. Ανακαλύψτε περισσότερες συμβουλές και κόλπα για το Excel εδώ.

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

Δημοφιλή χαρακτηριστικά: Εύρεση, επισήμανση ή αναγνώριση διπλότυπων   |  Διαγραφή κενών γραμμών   |  Συνδυάστε στήλες ή κελιά χωρίς απώλεια δεδομένων   |   Γύρος χωρίς φόρμουλα ...
Σούπερ Αναζήτηση: VLookup πολλαπλών κριτηρίων    VLookup πολλαπλών τιμών  |   VLookup σε πολλά φύλλα   |   Ασαφής αναζήτηση ....
Σύνθετη αναπτυσσόμενη λίστα: Γρήγορη δημιουργία αναπτυσσόμενης λίστας   |  Εξαρτημένη αναπτυσσόμενη λίστα   |  Πολλαπλή αναπτυσσόμενη λίστα ....
Διαχειριστής στήλης: Προσθέστε έναν συγκεκριμένο αριθμό στηλών  |  Μετακίνηση στηλών  |  Εναλλαγή κατάστασης ορατότητας κρυφών στηλών  |  Συγκρίνετε εύρη και στήλες ...
Επιλεγμένα Χαρακτηριστικά: Εστίαση πλέγματος   |  Προβολή σχεδίου   |   Μεγάλη Formula Bar    Διαχείριση βιβλίου εργασίας & φύλλου   |  Βιβλιοθήκη πόρων (Αυτόματο κείμενο)   |  Επιλογή ημερομηνίας   |  Συνδυάστε φύλλα εργασίας   |  Κρυπτογράφηση/Αποκρυπτογράφηση κελιών    Αποστολή email ανά λίστα   |  Σούπερ φίλτρο   |   Ειδικό φίλτρο (φίλτρο με έντονη γραφή/πλάγια γραφή/διαγραφή...) ...
Κορυφαία 15 σύνολα εργαλείων12 Κείμενο Εργαλεία (Προσθήκη κειμένου, Κατάργηση χαρακτήρων, ...)   |   50 + Διάγραμμα Τύποι (Gantt διάγραμμα, ...)   |   40+ Πρακτικό ΜΑΘΗΜΑΤΙΚΟΙ τυποι (Υπολογίστε την ηλικία με βάση τα γενέθλια, ...)   |   19 Εισαγωγή Εργαλεία (Εισαγωγή κωδικού QR, Εισαγωγή εικόνας από το μονοπάτι, ...)   |   12 Μετατροπή Εργαλεία (Αριθμοί σε λέξεις, Μετατροπή Συναλλάγματος, ...)   |   7 Συγχώνευση & διαχωρισμός Εργαλεία (Σύνθετες σειρές συνδυασμού, Διαίρεση κελιών, ...)   |   ... κι αλλα

Αυξήστε τις δεξιότητές σας στο Excel με τα Kutools για Excel και απολαύστε την αποτελεσματικότητα όπως ποτέ πριν. Το Kutools για Excel προσφέρει πάνω από 300 προηγμένες δυνατότητες για την ενίσχυση της παραγωγικότητας και την εξοικονόμηση χρόνου.  Κάντε κλικ εδώ για να αποκτήσετε τη δυνατότητα που χρειάζεστε περισσότερο...

kte καρτέλα 201905


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

  • Ενεργοποίηση επεξεργασίας και ανάγνωσης καρτελών σε Word, Excel, PowerPoint, Publisher, Access, Visio και Project.
  • Ανοίξτε και δημιουργήστε πολλά έγγραφα σε νέες καρτέλες του ίδιου παραθύρου και όχι σε νέα παράθυρα.
  • Αυξάνει την παραγωγικότητά σας κατά 50% και μειώνει εκατοντάδες κλικ του ποντικιού για εσάς κάθε μέρα!
Comments (70)
No ratings yet. Be the first to rate!
This comment was minimized by the moderator on the site
Thank you, this was very helpful.
This comment was minimized by the moderator on the site
Hi,
When I select 2 items from the drop-down list, if their starting parts are the same, it shortens the second one.
For example; imagine drop-down list items are CLASS 1-1, CLASS 1-2, CLASS 2-1 etc.
When I select first 2 items, it should write CLASS 1-1, 1-2 not CLASS 1-1, CLASS 1-2.
How should I add to the code? Thanks..
This comment was minimized by the moderator on the site
Hi, please guide me how I can merge the following two VBA Sheet codes (no in Module).
Thanks

Code 01:
Private Sub Worksheet_Change(ByVal Target As Range)
    'Updated by Extendoffice 2019/11/13
    Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    If Target.Count > 1 Then Exit Sub
    On Error Resume Next
    Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
    If xRng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    If Not Application.Intersect(Target, xRng) Is Nothing Then
        xValue2 = Target.Value
        Application.Undo
        xValue1 = Target.Value
        Target.Value = xValue2
        If xValue1 <> "" Then
            If xValue2 <> "" Then
                If xValue1 = xValue2 Or _
                   InStr(1, xValue1, ", " & xValue2) Or _
                   InStr(1, xValue1, xValue2 & ",") Then
                    Target.Value = xValue1
                Else
                    Target.Value = xValue1 & ", " & xValue2
                End If
            End If
        End If
    End If
    Application.EnableEvents = True
End Sub


Code 02:

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("D1")) Is Nothing Then Filter_namebakhsh Range("D1").Value

  If Not Intersect(Target, Range("F1")) Is Nothing Then Filter_saleshoroo Range("F1").Value

  If Not Intersect(Target, Range("H1")) Is Nothing Then Filter_salekhatameh Range("H1").Value

End Sub
This comment was minimized by the moderator on the site
Bonjour,

Dans une cellule où apparaitrait plusieurs choix de réponses, comment peut-on faire pour qu'il y ait un retour à la ligne pour chacun des choix?
This comment was minimized by the moderator on the site
Hi LeRomain,
Try the following code. Hope it can help.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2022/12/23
'Updated by Ken Gardner 2022/07/11
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
Dim semiColonCnt As Integer
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
'If Not Application.Intersect(Target, xRng) Is Nothing Then
If Application.Intersect(Target, xRng) Then
    xValue2 = Target.Value
    Application.Undo
    xValue1 = Target.Value
    Target.Value = xValue2
    If xValue1 <> "" Then
        If xValue1 = xValue2 Then
            Target.Value = ""
        ElseIf xValue2 <> "" Then
            If xValue1 = xValue2 Or xValue1 = xValue2 & ";" Or xValue1 = xValue2 & "; " Then ' leave the value if only one in list
                xValue1 = Replace(xValue1, vbLf, "")
                xValue1 = Replace(xValue1, vbLf, "")
                Target.Value = xValue1
            ElseIf InStr(1, xValue1, vbLf & xValue2) Then
                xValue1 = Replace(xValue1, vbLf & xValue2, "")  ' removes existing value from the list on repeat selection
                Target.Value = xValue1
            ElseIf InStr(1, xValue1, xValue2 & vbLf) Then
                xValue1 = Replace(xValue1, xValue2, "")
                Target.Value = xValue1
            Else
                Target.Value = xValue1 & vbLf & xValue2
            End If
            Target.Value = Replace(Target.Value, ";;", vbLf)
            Target.Value = Replace(Target.Value, "; ;", vbLf)
            If InStr(1, Target.Value, vbLf) = 1 Then  ' check for ; as first character and remove it
                Target.Value = Replace(Target.Value, vbLf, "", 1, 1)
            End If
            If InStr(1, Target.Value, vbLf) = 1 Then
                Target.Value = Replace(Target.Value, vbLf, "", 1, 1)
            End If
            semiColonCnt = 0
            For i = 1 To Len(Target.Value)
                If InStr(i, Target.Value, vbLf) Then
                    semiColonCnt = semiColonCnt + 1
                End If
            Next i
            If semiColonCnt = 1 Then ' remove ; if last character
                Target.Value = Replace(Target.Value, vbLf, "")
                Target.Value = Replace(Target.Value, vbLf, "")
            End If
        End If
    End If
End If
Application.EnableEvents = True
End Sub
This comment was minimized by the moderator on the site
Bonjour,
Si dans une cellule je souhaite que pour chacun des différents choix sélectionnés il y ait un retour à la ligne, comment faut-il faire?
This comment was minimized by the moderator on the site
(à l'attention de cristal)
Bonjour,

La macro fonctionne mais il me reste un dernier souci : Je voudrais que la macro fonctionne uniquement dans les colonnes V,W,X. J'ai vu que le sujet avait déjà été traité mais j'ignore quelles modifications apporter dans la mise à jour que vous venez de faire. Pouvez-vous apporter les modifications nécessaires s'il vous plaît ?

Merci.
This comment was minimized by the moderator on the site
Hi Said,

You just need to add the following line:
If Not (Target.Column > 21 And Target.Column < 25) Then Exit Sub
between the line "On Error Resume Next" and the line "xType = 0" line.
The entire VBA script is as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
    'Updated by Extendoffice 2023/01/12
    'Updated by Ken Gardner 2022/07/11
    Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    Dim semiColonCnt As Integer
    Dim xType As Integer
    If Target.Count > 1 Then Exit Sub
    On Error Resume Next
    
    If Not (Target.Column > 21 And Target.Column < 25) Then Exit Sub
    
    xType = 0
    xType = Target.Validation.Type
    If xType = 3 Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        xValue2 = Target.Value
        Application.Undo
        xValue1 = Target.Value
        Target.Value = xValue2
        If xValue1 <> "" Then
            If xValue2 <> "" Then
                If xValue1 = xValue2 Or xValue1 = xValue2 & ";" Or xValue1 = xValue2 & "; " Then ' leave the value if only one in list
                    xValue1 = Replace(xValue1, "; ", "")
                    xValue1 = Replace(xValue1, ";", "")
                    Target.Value = xValue1
                ElseIf InStr(1, xValue1, "; " & xValue2) Then
                    xValue1 = Replace(xValue1, xValue2, "") ' removes existing value from the list on repeat selection
                    Target.Value = xValue1
                ElseIf InStr(1, xValue1, xValue2 & ";") Then
                    xValue1 = Replace(xValue1, xValue2, "")
                    Target.Value = xValue1
                Else
                    Target.Value = xValue1 & "; " & xValue2
                End If
                Target.Value = Replace(Target.Value, ";;", ";")
                Target.Value = Replace(Target.Value, "; ;", ";")
                If Target.Value <> "" Then
                    If Right(Target.Value, 2) = "; " Then
                        Target.Value = Left(Target.Value, Len(Target.Value) - 2)
                    End If
                End If
                If InStr(1, Target.Value, "; ") = 1 Then ' check for ; as first character and remove it
                    Target.Value = Replace(Target.Value, "; ", "", 1, 1)
                End If
                If InStr(1, Target.Value, ";") = 1 Then
                    Target.Value = Replace(Target.Value, ";", "", 1, 1)
                End If
                semiColonCnt = 0
                For i = 1 To Len(Target.Value)
                    If InStr(i, Target.Value, ";") Then
                        semiColonCnt = semiColonCnt + 1
                    End If
                Next i
                If semiColonCnt = 1 Then ' remove ; if last character
                    Target.Value = Replace(Target.Value, "; ", "")
                    Target.Value = Replace(Target.Value, ";", "")
                End If
            End If
        End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub
This comment was minimized by the moderator on the site
Bonjour Cristal,

Peux-tu me dire quelles lignes de code il faut ajouter pour que la macro fonctionne dans plusieurs ensemble de colonnes stp ?
(exemple : la macro fonctionne dans les colonnes A,B,C et F,G,H et O,P,Q etc.

Merci
This comment was minimized by the moderator on the site
Bonjour Cristal,

Je suis vraiment désolé de te demander autant mais j'aurai une dernière requête …
J'aimerai que dans la colonne D par exemple, les choix s'affichent sur une nouvelle ligne sans changer la configuration des colonnes V,W,X.
J'ai vu qu'il fallait ajouter vBNewLine pour cela mais encore une fois je ne sais où l'insérer dans le code.
Pourrais-tu m'aider s'il te plaît ?

Merci
This comment was minimized by the moderator on the site
(A l'attention de Cristal)
Bonjour,

Je poste un nouveau commentaire car quand je réponds à un commentaire ça ne le publie pas.
La macro fonctionne bien mais il me reste un dernier souci : Je voudrais que la macro ne fonctionne que dans les colonnes V,W et X. J'ai vu que ce sujet avait été traité mais les modifications n'ont pas l'air de fonctionner quand j'essaie. Pouvez-vous m'apporter les modifications nécessaires s'il vous plaît ?

Merci
This comment was minimized by the moderator on the site
Bonjour,

J'ai un petit problème.
La macro fonctionne bien mais le problème est que les formules de base ne fonctionnent plus sur la feuille. Quand je fais une formule ça me donne bien le résultat mais le contenu de la cellule se transforme en résultat aussi (par exemple le résultat de ma formule est 1, quand je clique sur la cellule le contenu est 1 et non la formule).
Pouvez-vous m'apporter la modification pour ce problème svp ? (J'ai essayé de faire la modif pour que la macro fonctionne que sur certaines colonnes mais ça a pas l'air de fonctionner...)

PS : J'avais aussi le problème du point virgule qui restait quand on désélectionnait un choix, problème qui a été résolu plus haut dans les commentaires, pouvez-vous prendre en compte ce point aussi dans votre réponse svp ?

Merci.
This comment was minimized by the moderator on the site
Hi Said,

Sorry for the inconvenience. The code has been modified and updated in the post. Please give it a try. Thank you for your feedback.
Private Sub Worksheet_Change(ByVal Target As Range)
    'Updated by Extendoffice 2023/01/11
    'Updated by Ken Gardner 2022/07/11
    Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    Dim semiColonCnt As Integer
    Dim xType As Integer
    If Target.Count > 1 Then Exit Sub
    On Error Resume Next
    
    xType = 0
    xType = Target.Validation.Type
    If xType = 3 Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        xValue2 = Target.Value
        Application.Undo
        xValue1 = Target.Value
        Target.Value = xValue2
        If xValue1 <> "" Then
            If xValue2 <> "" Then
                If xValue1 = xValue2 Or xValue1 = xValue2 & ";" Or xValue1 = xValue2 & "; " Then ' leave the value if only one in list
                    xValue1 = Replace(xValue1, "; ", "")
                    xValue1 = Replace(xValue1, ";", "")
                    Target.Value = xValue1
                ElseIf InStr(1, xValue1, "; " & xValue2) Then
                    xValue1 = Replace(xValue1, xValue2, "") ' removes existing value from the list on repeat selection
                    Target.Value = xValue1
                ElseIf InStr(1, xValue1, xValue2 & ";") Then
                    xValue1 = Replace(xValue1, xValue2, "")
                    Target.Value = xValue1
                Else
                    Target.Value = xValue1 & "; " & xValue2
                End If
                Target.Value = Replace(Target.Value, ";;", ";")
                Target.Value = Replace(Target.Value, "; ;", ";")
                If Target.Value <> "" Then
                    If Right(Target.Value, 2) = "; " Then
                        Target.Value = Left(Target.Value, Len(Target.Value) - 2)
                    End If
                End If
                If InStr(1, Target.Value, "; ") = 1 Then ' check for ; as first character and remove it
                    Target.Value = Replace(Target.Value, "; ", "", 1, 1)
                End If
                If InStr(1, Target.Value, ";") = 1 Then
                    Target.Value = Replace(Target.Value, ";", "", 1, 1)
                End If
                semiColonCnt = 0
                For i = 1 To Len(Target.Value)
                    If InStr(i, Target.Value, ";") Then
                        semiColonCnt = semiColonCnt + 1
                    End If
                Next i
                If semiColonCnt = 1 Then ' remove ; if last character
                    Target.Value = Replace(Target.Value, "; ", "")
                    Target.Value = Replace(Target.Value, ";", "")
                End If
            End If
        End If
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub
This comment was minimized by the moderator on the site
Bonjour,

La macro fonctionne mais il me reste un dernier souci : Je voudrais que la macro fonctionne uniquement dans les colonnes V,W,X. J'ai vu que le sujet avait déjà été traité mais j'ignore quelles modifications apporter dans la mise à jour que vous venez de faire. Pouvez-vous apporter les modifications nécessaires s'il vous plaît ?

Merci.
This comment was minimized by the moderator on the site
Bonjour,

Tout fonctionne bien merci !
Cependant il me reste un dernier problème : Je voudrais que le macro ne fonctionne que dans les colonnes V,W,X. J'ai vu que cette question avait été posée auparavant mais les modifications que j'apporte n'ont pas l'air de fonctionner. Pouvez-vous apporter les modifications nécessaires s'il vous plaît ?

Merci
This comment was minimized by the moderator on the site
Bonjour,
Tout fonctionne parfaitement merci !
Mais il me reste un dernier petit souci : je voudrais que la macro ne fonctionne que dans les colonnes V,W,X. Pouvez-vous apporter la modification nécessaire s'il vous plaît ?
J'ai vu que cette question avait déjà été posée mais ça ne fonctionne pas quand j'apporte les modifications qui ont été données.

Merci.
This comment was minimized by the moderator on the site
Hallo, ich hoffe es kann mir geholfen werden:
Ich habe mir den VBA-Code 2 in meiner Tabelle hinterlegt um eine Mehrfachauswahl in einigen Zellen zu treffen.
Wenn ich allerdings mein Blatt schütze funktioniert die Mehrfachauswahl nicht mehr und es wird immer nur der jeweilige Wert eingefügt, den ich gerade anklicke und der vorherige gelöscht/überschrieben. Ich habe mich jetzt schon mehrere Tage durch´s Web gegoogelt, aber nicht das richtige als Abhilfe gefunden. Hat evtl. jemand einen Rat bzw. Tipp für mich???
Grüße, Marko
This comment was minimized by the moderator on the site
Hi,

The following VBA code can help you solve the problem. Before protecting the worksheet, you need to unlock the cells containing the data validation drop-down list.
If you are not good at handling VBA code, the third-party tool recommended in the post can help in a protected worksheet.
Private Sub Worksheet_Change(ByVal Target As Range)
    'Updated by Extendoffice 2022/12/23
    'Updated by Ken Gardner 2022/07/11
    Dim xRng As Range
    Dim xValue1 As String
    Dim xValue2 As String
    Dim semiColonCnt As Integer
    Dim xType As Integer
    If Target.Count > 1 Then Exit Sub
    
    
    On Error Resume Next
    
    
'    Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
'    If xRng Is Nothing Then Exit Sub
    
    
'        If Application.Intersect(Target, xRng) Then
    xType = 0
    xType = Target.Validation.Type
    If xType = 3 Then
        Application.EnableEvents = False
        xValue2 = Target.Value
        Application.Undo
        xValue1 = Target.Value
        Target.Value = xValue2
        If xValue1 <> "" Then
        If xValue2 <> "" Then
        If xValue1 = xValue2 Or xValue1 = xValue2 & ";" Or xValue1 = xValue2 & "; " Then ' leave the value if only one in list
        xValue1 = Replace(xValue1, "; ", "")
        xValue1 = Replace(xValue1, ";", "")
        Target.Value = xValue1
        ElseIf InStr(1, xValue1, "; " & xValue2) Then
        xValue1 = Replace(xValue1, xValue2, "") ' removes existing value from the list on repeat selection
        Target.Value = xValue1
        ElseIf InStr(1, xValue1, xValue2 & ";") Then
        xValue1 = Replace(xValue1, xValue2, "")
        Target.Value = xValue1
        Else
        Target.Value = xValue1 & "; " & xValue2
        End If
        Target.Value = Replace(Target.Value, ";;", ";")
        Target.Value = Replace(Target.Value, "; ;", ";")
        If InStr(1, Target.Value, "; ") = 1 Then ' check for ; as first character and remove it
        Target.Value = Replace(Target.Value, "; ", "", 1, 1)
        End If
        If InStr(1, Target.Value, ";") = 1 Then
        Target.Value = Replace(Target.Value, ";", "", 1, 1)
        End If
        semiColonCnt = 0
        For i = 1 To Len(Target.Value)
        If InStr(i, Target.Value, ";") Then
        semiColonCnt = semiColonCnt + 1
        End If
        Next i
        If semiColonCnt = 1 Then ' remove ; if last character
        Target.Value = Replace(Target.Value, "; ", "")
        Target.Value = Replace(Target.Value, ";", "")
        End If
        End If
        End If
        Application.EnableEvents = True
    End If
    
End Sub
This comment was minimized by the moderator on the site
Bonjour,
Dans le Code VBA 2 : Autoriser plusieurs sélections dans une liste déroulante sans doublons (supprimer les éléments existants en les sélectionnant à nouveau), je souhaiterai que les sélections s'affiche avec saut de ligne et non pas à la suite, séparé par un point virgule ";".
Savez vous que faut il changer dans le code ?
Merci par avance,
Cordialement,
This comment was minimized by the moderator on the site
Hi PaulM,

The following VBA code can do you a favor, please give it a try. Thank you.
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2022/12/23
'Updated by Ken Gardner 2022/07/11
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
Dim semiColonCnt As Integer
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
'If Not Application.Intersect(Target, xRng) Is Nothing Then
If Application.Intersect(Target, xRng) Then
    xValue2 = Target.Value
    Application.Undo
    xValue1 = Target.Value
    Target.Value = xValue2
    If xValue1 <> "" Then
        If xValue1 = xValue2 Then
            Target.Value = ""
        ElseIf xValue2 <> "" Then
            If xValue1 = xValue2 Or xValue1 = xValue2 & ";" Or xValue1 = xValue2 & "; " Then ' leave the value if only one in list
                xValue1 = Replace(xValue1, vbLf, "")
                xValue1 = Replace(xValue1, vbLf, "")
                Target.Value = xValue1
            ElseIf InStr(1, xValue1, vbLf & xValue2) Then
                xValue1 = Replace(xValue1, vbLf & xValue2, "")  ' removes existing value from the list on repeat selection
                Target.Value = xValue1
            ElseIf InStr(1, xValue1, xValue2 & vbLf) Then
                xValue1 = Replace(xValue1, xValue2, "")
                Target.Value = xValue1
            Else
                Target.Value = xValue1 & vbLf & xValue2
            End If
            Target.Value = Replace(Target.Value, ";;", vbLf)
            Target.Value = Replace(Target.Value, "; ;", vbLf)
            If InStr(1, Target.Value, vbLf) = 1 Then  ' check for ; as first character and remove it
                Target.Value = Replace(Target.Value, vbLf, "", 1, 1)
            End If
            If InStr(1, Target.Value, vbLf) = 1 Then
                Target.Value = Replace(Target.Value, vbLf, "", 1, 1)
            End If
            semiColonCnt = 0
            For i = 1 To Len(Target.Value)
                If InStr(i, Target.Value, vbLf) Then
                    semiColonCnt = semiColonCnt + 1
                End If
            Next i
            If semiColonCnt = 1 Then ' remove ; if last character
                Target.Value = Replace(Target.Value, vbLf, "")
                Target.Value = Replace(Target.Value, vbLf, "")
            End If
        End If
    End If
End If
Application.EnableEvents = True
End Sub
There are no comments posted here yet
Load More
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations