ไปยังเนื้อหาหลัก

เลือกหลายรายการในรายการแบบเลื่อนลงของ 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 สำหรับ Excel ได้ในไม่กี่คลิก

หากคุณไม่คุ้นเคยกับ VBA ทางเลือกที่ง่ายกว่าก็คือ Kutools สำหรับ Excel's เลือกรายการแบบหล่นลงได้หลายรายการ คุณสมบัติ. เครื่องมือที่เป็นมิตรต่อผู้ใช้นี้ช่วยลดความยุ่งยากในการเปิดใช้งานการเลือกหลายรายการในรายการแบบเลื่อนลง ช่วยให้คุณสามารถปรับแต่งตัวคั่นและจัดการรายการซ้ำได้อย่างง่ายดายเพื่อตอบสนองความต้องการที่แตกต่างกันของคุณ

หลังจาก การติดตั้ง Kutools สำหรับ Excelไปที่ Kutools เลือก รายการแบบหล่นลง > เลือกรายการแบบหล่นลงได้หลายรายการ. จากนั้นคุณจะต้องกำหนดค่าดังนี้

  1. ระบุช่วงที่มีรายการแบบเลื่อนลงที่คุณต้องการเลือกหลายรายการ
  2. ระบุตัวคั่นสำหรับรายการที่เลือกในเซลล์รายการแบบหล่นลง
  3. คลิก OK เพื่อทำการตั้งค่าให้เสร็จสมบูรณ์
ผล

ตอนนี้ เมื่อคุณคลิกเซลล์ที่มีรายการแบบเลื่อนลงในช่วงที่ระบุ กล่องรายการจะปรากฏขึ้นข้างๆ เพียงคลิกปุ่ม "+" ถัดจากรายการต่างๆ เพื่อเพิ่มลงในเซลล์แบบเลื่อนลง และคลิกปุ่ม "-" เพื่อลบรายการใดๆ ที่คุณไม่ต้องการอีกต่อไป ดูการสาธิตด้านล่าง:

หมายเหตุ / รายละเอียดเพิ่มเติม:
  • ตรวจสอบ ตัดข้อความหลังจากแทรกตัวคั่น ตัวเลือกถ้าคุณต้องการแสดงรายการที่เลือกในแนวตั้งภายในเซลล์ หากคุณต้องการรายการแนวนอน ไม่ต้องเลือกตัวเลือกนี้
  • ตรวจสอบ เปิดใช้การค้นหา ตัวเลือกหากคุณต้องการเพิ่มแถบค้นหาลงในรายการแบบเลื่อนลงของคุณ
  • หากต้องการใช้คุณลักษณะนี้ โปรด ดาวน์โหลดและติดตั้ง 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")
หมายเหตุ: ที่นี่ 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 ที่นี่.

สุดยอดเครื่องมือเพิ่มผลผลิตในสำนักงาน

🤖 Kutools AI ผู้ช่วย: ปฏิวัติการวิเคราะห์ข้อมูลโดยยึดตาม: การดำเนินการที่ชาญฉลาด   |  สร้างรหัส  |  สร้างสูตรที่กำหนดเอง  |  วิเคราะห์ข้อมูลและสร้างแผนภูมิ  |  เรียกใช้ฟังก์ชัน Kutools...
คุณสมบัติยอดนิยม: ค้นหา เน้น หรือระบุรายการที่ซ้ำกัน   |  ลบแถวว่าง   |  รวมคอลัมน์หรือเซลล์โดยไม่สูญเสียข้อมูล   |   รอบโดยไม่มีสูตร ...
การค้นหาขั้นสูง: VLookup หลายเกณฑ์    VLookup หลายค่า  |   VLookup ข้ามหลายแผ่น   |   การค้นหาที่ไม่ชัดเจน ....
รายการแบบเลื่อนลงขั้นสูง: สร้างรายการแบบหล่นลงอย่างรวดเร็ว   |  รายการแบบหล่นลงขึ้นอยู่กับ   |  เลือกหลายรายการแบบหล่นลง ....
ผู้จัดการคอลัมน์: เพิ่มจำนวนคอลัมน์เฉพาะ  |  ย้ายคอลัมน์  |  สลับสถานะการมองเห็นของคอลัมน์ที่ซ่อนอยู่  |  เปรียบเทียบช่วงและคอลัมน์ ...
คุณสมบัติเด่น: กริดโฟกัส   |  มุมมองการออกแบบ   |   บาร์สูตรใหญ่    สมุดงานและตัวจัดการชีต   |  ห้องสมุดทรัพยากร (ข้อความอัตโนมัติ)   |  เลือกวันที่   |  รวมแผ่นงาน   |  เข้ารหัส/ถอดรหัสเซลล์    ส่งอีเมลตามรายการ   |  ซุปเปอร์ฟิลเตอร์   |   ตัวกรองพิเศษ (กรองตัวหนา/ตัวเอียง/ขีดทับ...) ...
ชุดเครื่องมือ 15 อันดับแรก12 ข้อความ เครื่องมือ (เพิ่มข้อความ, ลบอักขระ, ... )   |   50 + แผนภูมิ ประเภท (แผนภูมิ Gantt, ... )   |   40+ ใช้งานได้จริง สูตร (คำนวณอายุตามวันเกิด, ... )   |   19 การแทรก เครื่องมือ (ใส่ QR Code, แทรกรูปภาพจากเส้นทาง, ... )   |   12 การแปลง เครื่องมือ (ตัวเลขเป็นคำ, การแปลงสกุลเงิน, ... )   |   7 ผสานและแยก เครื่องมือ (แถวรวมขั้นสูง, แยกเซลล์, ... )   |   ... และอื่น ๆ

เพิ่มพูนทักษะ Excel ของคุณด้วย Kutools สำหรับ Excel และสัมผัสประสิทธิภาพอย่างที่ไม่เคยมีมาก่อน Kutools สำหรับ Excel เสนอคุณสมบัติขั้นสูงมากกว่า 300 รายการเพื่อเพิ่มประสิทธิภาพและประหยัดเวลา  คลิกที่นี่เพื่อรับคุณสมบัติที่คุณต้องการมากที่สุด...

รายละเอียด


แท็บ Office นำอินเทอร์เฟซแบบแท็บมาที่ Office และทำให้งานของคุณง่ายขึ้นมาก

  • เปิดใช้งานการแก้ไขและอ่านแบบแท็บใน Word, Excel, PowerPoint, ผู้จัดพิมพ์, Access, Visio และโครงการ
  • เปิดและสร้างเอกสารหลายรายการในแท็บใหม่ของหน้าต่างเดียวกันแทนที่จะเป็นในหน้าต่างใหม่
  • เพิ่มประสิทธิภาพการทำงานของคุณ 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