(آموزشی) استفاده از منوی آبشاری با امکان انتخاب چند گانه و حذف همزمان

[rasools13]

سلام
عنوان : نحوه انتخاب چند گزینه همزمان و حذف کردن گزینه ها از منوی آبشاری
راه حل:
بر روی نام شیتی منوی آبشاری در ان قرار دارد کلیک راست کرده و viewCode را انتخاب کنید و کد ذیل را در کادر باز شده کپی نمایید

Private Sub Worksheet_Change(ByVal Target As Range)

Dim oldVal As String
Dim newVal As String
Dim strSep As String
Dim strType As Long
Dim AA As String
Dim HasVal As Boolean
Dim newValLen, newValPos As Double

'اضافه کردن ، بين گزينه ها
strSep = ", "
AA = Target.Address
If AA = "$C$4" Then 'آدرس سلولهايي که داراي منوي آبشاري هستند رو به اين قسمت اضافه کنيد
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
strType = Target.Validation.Type

Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
If newVal <> "" Then
HasVal = Application.WorksheetFunction.IsNumber(Application .WorksheetFunction.Search(newVal, oldVal))
Else
HasVal = False
End If
If HasVal = True Then
newValLen = Len(newVal)
newValPos = Application.WorksheetFunction.Find(newVal, oldVal)
If newValPos > 1 Then
Target.Value = Application.WorksheetFunction.Replace(oldVal, newValPos - 2, newValLen + 2, "")
Else
Target.Value = Application.WorksheetFunction.Replace(oldVal, newValPos, newValLen + 2, "")
End If
Else
If oldVal = "" Or newVal = "" Then
Target.Value = newVal
Else
Target.Value = oldVal _
& strSep & newVal
End If
End If
End If

exitHandler:
Application.EnableEvents = True
End Sub

در قسمتی که در کد نیز مشخص شده است ادرس سلول یا سلوهایی که دارای منوی آبشاریی هست را مشخص کنید
حال با انتخاب هر گزینه از منوی آبشاری گزینه انتخابی به لیست اضافه شده و بانتخاب مجدد ان از موارد انتخاب شده حذف خواهد شد.
14182
امیدوارم به کارتون بیاد