Bỏ qua nội dung chính

Chọn nhiều mục trong danh sách thả xuống Excel – hướng dẫn đầy đủ

Danh sách thả xuống của Excel là một công cụ tuyệt vời để đảm bảo tính nhất quán của dữ liệu và dễ dàng nhập liệu. Tuy nhiên, theo mặc định, họ hạn chế bạn chỉ chọn một mục. Nhưng nếu bạn cần chọn nhiều mục từ cùng một danh sách thả xuống thì sao? Hướng dẫn toàn diện này sẽ khám phá các phương pháp để bật nhiều lựa chọn trong danh sách thả xuống của Excel, quản lý các bản sao, đặt dấu phân cách tùy chỉnh và xác định phạm vi của các danh sách này.

Mẹo: Trước khi áp dụng các phương pháp sau, hãy đảm bảo rằng bạn đã tạo trước danh sách thả xuống trong bảng tính của mình. Nếu bạn muốn biết cách tạo danh sách thả xuống xác thực dữ liệu, hãy làm theo hướng dẫn trong bài viết này: Cách tạo danh sách thả xuống xác thực dữ liệu trong Excel.

Kích hoạt nhiều lựa chọn trong danh sách thả xuống

Phần này cung cấp hai phương pháp giúp bạn kích hoạt nhiều lựa chọn trong danh sách thả xuống trong Excel.

Sử dụng mã VBA

Để cho phép nhiều lựa chọn trong danh sách thả xuống, bạn có thể sử dụng Visual Basic cho các ứng dụng (VBA) trong Excel. Tập lệnh có thể sửa đổi hành vi của danh sách thả xuống để biến nó thành danh sách trắc nghiệm. Hãy làm như sau.

Bước 1: Mở trình soạn thảo Sheet (Code)
  1. Mở trang tính chứa danh sách thả xuống mà bạn muốn bật nhiều lựa chọn.
  2. Nhấp chuột phải vào tab trang tính và chọn Mã Chế độ xem từ trình đơn ngữ cảnh.
Bước 2: Sử dụng mã VBA

Bây giờ sao chép mã VBA sau và dán nó vào cửa sổ bảng mở (Mã).

Mã VBA: Bật nhiều lựa chọn trong danh sách thả xuống 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

Kết quả

Khi bạn quay lại bảng tính, danh sách thả xuống sẽ cho phép bạn chọn nhiều tùy chọn, xem bản demo bên dưới:

Chú ý:
Mã VBA ở trên:
  • Áp dụng cho tất cả danh sách thả xuống xác thực dữ liệu trong trang tính hiện tại, cả danh sách hiện tại và danh sách được tạo trong tương lai.
  • Ngăn bạn chọn cùng một mục nhiều lần trong mỗi danh sách thả xuống.
  • Sử dụng dấu phẩy làm dấu phân cách cho các mục đã chọn. Để sử dụng các dấu phân cách khác, vui lòng xem phần này để thay đổi dấu phân cách.

Sử dụng Kutools cho Excel chỉ trong vài cú nhấp chuột

Nếu bạn không thoải mái với VBA, một giải pháp thay thế dễ dàng hơn là Kutools cho Excel's Danh sách thả xuống nhiều lựa chọn tính năng. Công cụ thân thiện với người dùng này đơn giản hóa việc bật nhiều lựa chọn trong danh sách thả xuống, cho phép bạn tùy chỉnh dấu phân cách và quản lý các bản sao một cách dễ dàng để đáp ứng các nhu cầu khác nhau của bạn.

Sau cài đặt Kutools cho Excel, Đi đến Kutools tab, chọn Danh sách thả xuống > Danh sách thả xuống nhiều lựa chọn. Sau đó, bạn cần phải cấu hình như sau.

  1. Chỉ định phạm vi chứa danh sách thả xuống mà bạn cần chọn nhiều mục từ đó.
  2. Chỉ định dấu phân cách cho các mục đã chọn trong ô danh sách thả xuống.
  3. Nhấp chuột OK để hoàn thành cài đặt.
Kết quả

Bây giờ, khi bạn bấm vào ô có danh sách thả xuống trong phạm vi đã chỉ định, một hộp danh sách sẽ xuất hiện bên cạnh ô đó. Chỉ cần nhấp vào nút "+" bên cạnh các mục để thêm chúng vào ô thả xuống và nhấp vào nút "-" để xóa bất kỳ mục nào bạn không muốn nữa. Xem bản demo bên dưới:

Chú ý:
  • Kiểm tra Ngắt dòng văn bản sau khi chèn dấu phân cách tùy chọn nếu bạn muốn hiển thị các mục đã chọn theo chiều dọc trong ô. Nếu bạn thích danh sách theo chiều ngang, hãy bỏ chọn tùy chọn này.
  • Kiểm tra Cho phép tìm kiếm tùy chọn nếu bạn muốn thêm thanh tìm kiếm vào danh sách thả xuống của mình.
  • Để áp dụng tính năng này, vui lòng tải xuống và cài đặt Kutools cho Excel đầu tiên.

Thêm thao tác cho danh sách thả xuống nhiều lựa chọn

Phần này thu thập các kịch bản khác nhau có thể được yêu cầu khi bật nhiều lựa chọn trong danh sách thả xuống Xác thực dữ liệu.

Cho phép các mục trùng lặp trong danh sách thả xuống

Sự trùng lặp có thể là một vấn đề khi nhiều lựa chọn được cho phép trong danh sách thả xuống. Mã VBA ở trên không cho phép các mục trùng lặp trong danh sách thả xuống. Nếu bạn cần giữ lại các mục trùng lặp, hãy thử mã VBA trong phần này.

Mã VBA: Cho phép trùng lặp trong danh sách thả xuống xác thực dữ liệu

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
Kết quả

Bây giờ bạn có thể chọn nhiều mục từ danh sách thả xuống trong bảng tính hiện tại. Để lặp lại một mục trong ô danh sách thả xuống, hãy tiếp tục chọn mục đó từ danh sách. Xem ảnh chụp màn hình:

Xóa mọi mục hiện có khỏi danh sách thả xuống

Sau khi chọn nhiều mục từ danh sách thả xuống, đôi khi bạn có thể cần xóa một mục hiện có khỏi ô danh sách thả xuống. Phần này cung cấp một đoạn mã VBA khác để giúp bạn hoàn thành nhiệm vụ này.

Mã VBA: Xóa mọi mục hiện có khỏi ô danh sách thả xuống

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
Kết quả

Mã VBA này cho phép bạn chọn nhiều mục từ danh sách thả xuống và dễ dàng xóa bất kỳ mục nào bạn đã chọn. Sau khi chọn nhiều mục, nếu muốn xóa một mục cụ thể, bạn chỉ cần chọn lại mục đó từ danh sách.

Đặt dấu phân cách tùy chỉnh

Dấu phân cách được đặt là dấu phẩy trong các mã VBA ở trên. Bạn có thể sửa đổi biến này thành bất kỳ ký tự ưa thích nào để sử dụng làm dấu phân cách cho các lựa chọn trong danh sách thả xuống. Đây là cách bạn có thể làm:

Như bạn có thể thấy rằng các mã VBA ở trên đều có dòng sau:

delimiter = ", "

Bạn chỉ cần thay đổi dấu phẩy thành bất kỳ dấu phân cách nào bạn cần. Ví dụ bạn muốn phân tách các mục bằng dấu chấm phẩy thì đổi dòng thành:

delimiter = "; "
Lưu ý: Để thay đổi dấu phân cách thành ký tự dòng mới trong các mã VBA này, hãy thay đổi dòng này thành:
delimiter = vbNewLine

Đặt phạm vi được chỉ định

Mã VBA ở trên áp dụng cho tất cả danh sách thả xuống trong bảng tính hiện tại. Nếu bạn chỉ muốn mã VBA áp dụng cho một phạm vi danh sách thả xuống nhất định, bạn có thể chỉ định phạm vi trong mã VBA ở trên như sau.

Như bạn có thể thấy rằng các mã VBA ở trên đều có dòng sau:

Set TargetRange = Me.UsedRange

Bạn chỉ cần thay đổi dòng thành:

Set TargetRange = Me.Range("C2:C10")
Chú thích: Ở đây C2: C10 là phạm vi chứa danh sách thả xuống mà bạn muốn đặt thành nhiều lựa chọn.

Thực thi trong một bảng tính được bảo vệ

Hãy tưởng tượng rằng bạn đã bảo vệ một bảng tính bằng mật khẩu "123" và đặt các ô trong danh sách thả xuống thành "Unlocked" trước khi kích hoạt tính năng bảo vệ, nhờ đó đảm bảo rằng chức năng chọn nhiều lựa chọn vẫn hoạt động sau khi bảo vệ. Tuy nhiên, các mã VBA được đề cập ở trên không thể hoạt động trong trường hợp này và phần này mô tả một tập lệnh VBA khác được thiết kế đặc biệt để xử lý chức năng đa lựa chọn trong một bảng tính được bảo vệ.

Mã VBA: Cho phép nhiều lựa chọn trong danh sách thả xuống mà không trùng lặp


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
Chú thích: Trong mã, đảm bảo thay thế “mật khẩu của bạn” trong dòng pswd = "Mật khẩu của bạn" bằng mật khẩu thực tế bạn sử dụng để bảo vệ bảng tính. Ví dụ: nếu mật khẩu của bạn là "Abc123", thì dòng này sẽ là pswd = "abc123".

Bằng cách bật nhiều lựa chọn trong danh sách thả xuống của Excel, bạn có thể nâng cao đáng kể chức năng và tính linh hoạt của bảng tính của mình. Cho dù bạn cảm thấy thoải mái với mã hóa VBA hay thích giải pháp đơn giản hơn như Kutools, giờ đây bạn có khả năng chuyển đổi danh sách thả xuống tiêu chuẩn của mình thành các công cụ động, có nhiều lựa chọn. Với những kỹ năng này, giờ đây bạn đã được trang bị để tạo các tài liệu Excel năng động và thân thiện hơn với người dùng. Đối với những người mong muốn tìm hiểu sâu hơn về các khả năng của Excel, trang web của chúng tôi tự hào có rất nhiều hướng dẫn. Khám phá thêm các mẹo và thủ thuật Excel tại đây.

Công cụ năng suất văn phòng tốt nhất

🤖 Trợ lý AI của Kutools: Cách mạng hóa việc phân tích dữ liệu dựa trên: Thực thi thông minh   |  Tạo mã  |  Tạo công thức tùy chỉnh  |  Phân tích dữ liệu và tạo biểu đồ  |  Gọi các hàm Kutools...
Các tính năng phổ biến: Tìm, đánh dấu hoặc xác định các bản sao   |  Xóa hàng trống   |  Kết hợp các cột hoặc ô mà không làm mất dữ liệu   |   Vòng không có công thức hữu ích. Cảm ơn !
Siêu tra cứu: Nhiều tiêu chí VLookup  |   VLookup Nhiều Giá Trị  |   VLookup trên nhiều trang tính   |   Tra cứu mờ ....
Danh sách thả xuống nâng cao: Tạo nhanh danh sách thả xuống   |  Danh sách thả xuống phụ thuộc   |  Danh sách thả xuống nhiều lựa chọn ....
Trình quản lý cột: Thêm một số cột cụ thể  |  Di chuyển cột  |  Chuyển đổi trạng thái hiển thị của các cột ẩn  |  So sánh dãy và cột hữu ích. Cảm ơn !
Các tính năng nổi bật: Tiêu điểm lưới   |  Chế độ xem thiết kế   |   Thanh công thức lớn   |  Trình quản lý sổ làm việc & trang tính   |  Thư viện tài nguyên (Văn bản tự động)   |  Bảng chọn ngày   |  Kết hợp các bảng tính   |  Mã hóa/Giải mã ô   |  Gửi email theo danh sách   |  Siêu lọc   |   Bộ lọc đặc biệt (lọc in đậm/nghiêng/gạch ngang...) ...
15 bộ công cụ hàng đầu:  12 bản văn CÔNG CỤ (thêm văn bản, Xóa ký tự,...)   |   50 + Biểu đồ Các loại (Biểu đồ Gantt,...)   |   40+ Thực tế Công thức (Tính tuổi dựa trên ngày sinh,...)   |   19 chèn CÔNG CỤ (Chèn mã QR, Chèn ảnh từ đường dẫn,...)   |   12 Chuyển đổi CÔNG CỤ (Số thành từ, Chuyển đổi tiền tệ,...)   |   7 Hợp nhất & Tách CÔNG CỤ (Các hàng kết hợp nâng cao, Chia ô,...)   |   ... và nhiều hơn nữa

Nâng cao kỹ năng Excel của bạn với Kutools for Excel và trải nghiệm hiệu quả hơn bao giờ hết. Kutools for Excel cung cấp hơn 300 tính năng nâng cao để tăng năng suất và tiết kiệm thời gian.  Bấm vào đây để có được tính năng bạn cần nhất...

Mô tả

Tab Office mang lại giao diện Tab cho Office và giúp công việc của bạn trở nên dễ dàng hơn nhiều

  • Cho phép chỉnh sửa và đọc theo thẻ trong Word, Excel, PowerPoint, Publisher, Access, Visio và Project.
  • Mở và tạo nhiều tài liệu trong các tab mới của cùng một cửa sổ, thay vì trong các cửa sổ mới.
  • Tăng 50% năng suất của bạn và giảm hàng trăm cú nhấp chuột cho bạn mỗi ngày!
Comments (70)
No ratings yet. Be the first to rate!
Yiota
Yiota
This comment was minimized by the moderator on the site
Thank you, this was very helpful.
Reply
0
0
Quasimodo
Quasimodo
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..
Reply
0
0
shafiey
shafiey
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
Reply
Report
1
0
LeRomain
LeRomain
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?
Reply
0
0
crystal
crystal     LeRomain
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
Reply
Report
0
0
LeRomain
LeRomain
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?
Reply
0
0
Said52
Said52
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.
Reply
Report
0
0
crystal
crystal     Said52
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
Reply
Report
0
0
SaidZ
SaidZ     crystal
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
Reply
0
0
Said
Said     crystal
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
Reply
0
0
Said
Said
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
Reply
0
0
Said
Said
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.
Reply
0
0
crystal
crystal     Said
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
Reply
Report
0
0
Said52
Said52     crystal
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.
Reply
Report
0
0
Said
Said     crystal
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
Reply
0
0
Said
Said     crystal
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.
Reply
0
0
Marko
Marko
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
Reply
0
0
crystal
crystal     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
Reply
Report
0
0
PaulM
PaulM
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,
Reply
0
0
crystal
crystal     PaulM
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
Reply
Report
0
0
There are no comments posted here yet
Load More
Please leave your comments in English
Guest
Posting as Guest
×
Rate this post:
Reset
0   Characters
Suggested Locations