跳到主要內容

在 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

結果

當您返回工作表時,下拉清單將允許您選擇多個選項,請參閱下面的示範:

筆記:
上面的VBA程式碼:
  • 適用於目前工作表中的所有資料驗證下拉列表,包括現有的和將來建立的。
  • 防止您在每個下拉清單中多次選擇相同的項目。
  • 使用逗號作為所選項目的分隔符號。若要使用其他分隔符,請 查看此部分以更改分隔符.

只需點擊幾下即可使用 Kutools for Excel

如果您對 VBA 不滿意,還有一個更簡單的選擇: Excel的Kutools's 多選下拉列表 特徵。這個使用者友善的工具簡化了在下拉清單中啟用多個選擇的過程,提供了各種範圍,例如特定範圍、目前工作表、整個工作簿或所有開啟的工作簿。此外,它還允許您自訂分隔符號並輕鬆管理重複項,以滿足您的不同需求。

安裝 Kutools for Excel,轉到 庫工具 標籤,選擇 下拉列表 > 多選下拉列表。然後需要進行如下配置。

  1. 指定要套用此功能的位置 設定範圍 部分。
  2. 指定儲存格中所選項目的分隔符號。
  3. 決定文字方向。
  4. 點擊 OK.
結果

現在,當您單擊帶有下拉清單的儲存格時,它旁邊會出現一個列錶框。只需單擊項目旁邊的“+”按鈕即可將其新增至下拉式儲存格,然後按一下“-”按鈕以刪除您不需要的任何項目。請參閱下面的演示:

備註: 要應用此功能,請 下載並安裝 Kutools for 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")
備註: 這裡 C2:C10 是包含要設定為多項選擇的下拉清單的範圍。

在受保護的工作表中執行

假設您使用密碼“保護工作表”123”並將下拉清單單元格設定為“解鎖」 在啟動保護之前,從而確保多選功能在保護後保持活動狀態。但是,上述 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
備註:在代碼中,確保替換“你的密碼” 行中 pswd = "你的密碼" 使用您用於保護工作表的實際密碼。例如,如果您的密碼是“abc123「,那麼該行應該是 pswd =“abc123”.

透過在 Excel 下拉清單中啟用多項選擇,您可以大幅增強工作表的功能和靈活性。無論您熟悉 VBA 編碼還是喜歡 Kutools 等更簡單的解決方案,您現在都可以將標準下拉清單轉換為動態的多選工具。有了這些技能,您現在就可以建立更動態且使用者友好的 Excel 文件。對於那些渴望深入研究 Excel 功能的人,我們的網站擁有豐富的教學。 在這裡了解更多 Excel 提示和技巧.

最佳辦公生產力工具

熱門特色: 尋找、突出顯示或識別重複項   |  刪除空白行   |  合併列或儲存格而不遺失數據   |   沒有公式的回合 ...
超級查詢: 多條件VLookup    多值VLookup  |   跨多個工作表的 VLookup   |   模糊查詢 ....
高級下拉列表: 快速建立下拉列表   |  依賴下拉列表   |  多選下拉列表 ....
欄目經理: 新增特定數量的列  |  移動列  |  切換隱藏列的可見性狀態  |  比較範圍和列 ...
特色功能: 網格焦點   |  設計圖   |   大方程式酒吧    工作簿和工作表管理器   |  資源庫 (自動文字)   |  日期選擇器   |  合併工作表   |  加密/解密單元格    按清單發送電子郵件   |  超級濾鏡   |   特殊過濾器 (過濾粗體/斜體/刪除線...)...
前 15 個工具集12 文本 工具 (添加文本, 刪除字符,...)   |   50+ 圖表 類型 (甘特圖,...)   |   40+ 實用 公式 (根據生日計算年齡,...)   |   19 插入 工具 (插入二維碼, 從路徑插入圖片,...)   |   12 轉化 工具 (數字到單詞, 貨幣兌換,...)   |   7 合併與拆分 工具 (高級合併行, 分裂細胞,...)   |   ... 和更多

使用 Kutools for Excel 增強您的 Excel 技能,體驗前所未有的效率。 Kutools for Excel 提供了 300 多種進階功能來提高生產力並節省時間。  點擊此處獲取您最需要的功能...

kte選項卡201905


Office選項卡為Office帶來了選項卡式界面,使您的工作更加輕鬆

  • 在Word,Excel,PowerPoint中啟用選項卡式編輯和閱讀,發布者,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