क्या कुछ सूची तत्वों द्वारा तालिका को फ़िल्टर करने के लिए एक मैक्रो है?

Question

मेरे पास एक सूची के आधार पर प्रविष्टियों के साथ एक तालिका है और मैंने एक मैक्रो का उपयोग किया है जो मैंने पाया कि सूची में कई तत्वों को एक सेल में जोड़ने / निकालने में सक्षम होने के लिए, मैं आपको एक उदाहरण दिखाता हूं:

TEST TABLE
test1
test1, test2
test1, test3
test2, test3, test4

जहां सूची से आइटम test1, test2 और इसी तरह के हैं।

अब मुझे नहीं पता कि क्या यह संभव है, लेकिन मैं सूची से विशिष्ट आइटम द्वारा तालिका को तुरंत फ़िल्टर करने में सक्षम होना चाहूंगा (उदाहरण के लिए test1), इसके अलावा मैं इन मानदंडों को एक chceckbox फ़िल्टर में रखना चाहूंगा ताकि चेकबॉक्स में "टेस्ट 1, टेस्ट 2" जैसे चेकबॉक्स के बजाय मेरे पास सूची से केवल एक आइटम होगा (जैसे टेस्ट 1, टेस्ट 2 और इसी तरह)

क्या यह भी संभव है, और यदि कोई इसके लिए मैक्रो तैयार करने में मदद कर सकता है? इसके अलावा मैं यहाँ कार्यपुस्तिका से अपना मैक्रो डाल रहा हूँ:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler

On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler

If rngDV Is Nothing Then GoTo exitHandler

If Intersect(Target, rngDV) Is Nothing Then
   'do nothing
Else
  Application.EnableEvents = False
  newVal = Target.Value
  Application.Undo
  oldVal = Target.Value
  Target.Value = newVal
    If oldVal = "" Then
      'do nothing
      Else
      If newVal = "" Then
      'do nothing
      Else
        lUsed = InStr(1, oldVal, newVal)
        If lUsed > 0 Then
            If Right(oldVal, Len(newVal)) = newVal Then
                Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
            Else
                Target.Value = Replace(oldVal, newVal & ", ", "")
            End If
        Else
            Target.Value = oldVal _
              & ", " & newVal
        End If

      End If
  End If
End If

exitHandler:
  Application.EnableEvents = True

Call AutoFitColumns

End Sub

Sub AutoFitColumns()
Dim rng As Range
Set rng = Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
rng.EntireColumn.AutoFit
End Sub

Comments

आपको vba में ऑटोफिल्टर का उपयोग करने के बारे में जानकारी प्राप्त करने में सक्षम होना चाहिए, या आप मैक्रो रिकॉर्डर का उपयोग कर सकते हैं। आपको अपने मापदंड में एक सरणी का उपयोग करने की आवश्यकता होगी जिसमें आपके द्वारा फ़िल्टर किए जाने वाले सभी पाठ हैं। निम्नलिखित सेल में सभी नामों के लिए पीडीएफ, डॉक या डॉक्स के साथ फ़िल्टर करेगा। Criteria1:=Array(".pdf", ".doc", ".docx"), Operator:=xlFilterValues

— gtwebb

यदि आप एक्सेल 2010 का उपयोग कर रहे हैं, तो आप ऑटोफिल्टर सेट कर सकते हैं, और इसमें एक नया टेक्स्ट बॉक्स विकल्प है जो आप चाहते हैं (केवल टेक्स्ट बॉक्स होने के बजाय)। तो अब आप टेस्ट 1 टाइप कर सकते हैं और उन सभी कोशिकाओं को फ़िल्टर कर सकते हैं जिनमें टेस्ट 1 है। यदि आप कुछ अधिक उपयोगकर्ता के अनुकूल चाहते थे, तो आप अपने आप को ऐसा करते हुए रिकॉर्ड कर सकते थे, फिर परिणामी मैक्रो का उपयोग उन विकल्पों को बनाने के लिए कर सकते हैं जिन्हें आप खोज रहे हैं।

— गिटार वादक

Answer 1

हालांकि यह एक पुरानी पोस्ट है, मैं इसे संदर्भ के रूप में करने का एक तरीका प्रदान कर रहा हूं

• "UserForm1" डिफ़ॉल्ट नाम के साथ एक नया UserForm बनाएँ
• इस तरह के रूप में डिफ़ॉल्ट नाम "कॉम्बो बॉक्स 1" के साथ एक नया कॉम्बो बॉक्स बनाएं

---

इस कोड को फॉर्म के लिए VBA मॉड्यूल में जोड़ें:

---

Option Explicit

Private enableEvts As Boolean
Private thisCol As Range

Private Sub ComboBox1_Change()
   If enableEvts Then filterColumn thisCol, ComboBox1.Text
   'Me.Hide
End Sub

Public Sub setupList(ByRef col As Range)
   Set thisCol = col
   enableEvts = False
      setList col, ComboBox1
   enableEvts = True
   Me.Caption = "Filter Column: " & Left(col.Address(, False), 1)
End Sub

Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
   If KeyAscii = vbKeyEscape Then Me.Hide
End Sub
Private Sub CommandButton1_Click()
   ComboBox1.ListIndex = -1
   If Not Sheet1.AutoFilter Is Nothing Then Sheet1.UsedRange.AutoFilter
End Sub
Private Sub CommandButton2_Click()
   Me.Hide
End Sub
Private Sub UserForm_Click()
   Me.Hide
End Sub

---

इस कोड को शीट 1 के लिए VBA मॉड्यूल में पेस्ट करें:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   With Target
      If .CountLarge = 1 Then
         removeAllFilters Me
         If .Row = 1 Then
            .Offset(1, 0).Activate
            UserForm1.setupList Me.UsedRange.Columns(.Column)
            UserForm1.Show
         End If
      End If
   End With
End Sub

शीट 1 डेटा:

---

इस कोड को एक मानक VBA मॉड्यूल में खोलें (VBA खोलें: Alt+ F11, मेनू सम्मिलित करें> मॉड्यूल पर क्लिक करें)

Option Explicit

Public Sub setList(ByRef rng As Range, ByRef cmb As ComboBox)
   Dim ws As Worksheet, lst As Range, lr As Long

   If rng.Columns.Count = 1 Then
      xlEnabled False
      Set ws = rng.Parent
      removeAllFilters ws
      Set lst = ws.UsedRange.Columns(rng.Column)
      lr = getLastRow(lst, rng.Column)

      If lr > 1 Then
         With cmb
            .List = Split(getDistinct(lst, lr), ",")
            .ListIndex = -1
         End With
      End If
      xlEnabled True
   End If
End Sub

Public Sub xlEnabled(ByVal onOff As Boolean)
    Application.ScreenUpdating = onOff
    Application.EnableEvents = onOff
End Sub

Private Function getLastRow(ByRef rng As Range, ByVal lc As Long) As Long
   Dim ws As Worksheet, lr As Long
   If Not rng Is Nothing Then
      Set ws = rng.Parent
      lr = ws.Cells(rng.Row + ws.UsedRange.Rows.Count + 1, lc).End(xlUp).Row
      Set rng = ws.Range(ws.Cells(1, lc), ws.Cells(lr, lc)) 'updates rng (ByRef)
   End If
   getLastRow = lr
End Function

---

Private Function getDistinct(ByRef rng As Range, ByVal lr As Long) As String
   Dim ws As Worksheet, lst As String, lc As Long, tmp As Range, v As Variant, c As Double

   Set ws = rng.Parent
   lc = ws.Cells(rng.Row, rng.Column + ws.UsedRange.Columns.Count + 1).End(xlToLeft).Column
   Set tmp = ws.Range(ws.Cells(1, lc + 1), ws.Cells(lr, lc + 1))

   If tmp.Count > 1 Then
      With tmp.Cells(1, 1)
         .Formula = "=Trim(" & ws.Cells(rng.Row, lc).Address(False, False) & ")"
         .AutoFill Destination:=tmp
      End With

      tmp.Value2 = tmp.Value2       'convert formulas to values
      tmp.Cells(1, 1).ClearContents 'remove header from list
      cleanCol tmp, lc
      lr = getLastRow(tmp, lc + 1)

      lst = Join(Application.Transpose(tmp), ",")
      lst = Replace(lst, ", ", ","):   lst = Replace(lst, " ,", ",")
      v = Application.Transpose(Split(lst, ","))

      lr = UBound(v)
      ws.Range(ws.Cells(1, lc + 1), ws.Cells(lr, lc + 1)) = v
      getLastRow tmp, lc + 1

      cleanCol tmp, lc
      getLastRow tmp, lc + 1
      lst = Join(Application.Transpose(tmp), ",")
      lst = Replace(lst, ", ", ","):   lst = Replace(lst, " ,", ",")
      tmp.Cells(1, 1).EntireColumn.Clear
   End If
   getDistinct = lst
End Function

---

Public Sub filterColumn(ByRef col As Range, ByVal fltrCriteria As String)
   Dim ws As Worksheet, lst As Range, lr As Long

   xlEnabled False
   Set ws = col.Parent
   Set lst = ws.UsedRange.Columns(col.Column)
   lr = getLastRow(lst, col.Column)

   lst.AutoFilter
   lst.AutoFilter Field:=1, Criteria1:="*" & fltrCriteria & "*"
   xlEnabled True
End Sub

Private Sub cleanCol(ByRef tmp As Range, ByVal lc As Long)
   Dim ws As Worksheet, lr As Long

   Set ws = tmp.Parent
   tmp.RemoveDuplicates Columns:=1, Header:=xlNo
   lr = getLastRow(tmp, lc + 1)

   ws.Sort.SortFields.Add Key:=ws.Cells(lr + 1, lc + 1), Order:=xlAscending
   With ws.Sort
      .SetRange tmp
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .Apply
   End With
End Sub

Public Sub removeAllFilters(ByRef ws As Worksheet)

   If Not ws.AutoFilter Is Nothing Then ws.UsedRange.AutoFilter
   ws.Rows.Hidden = False

End Sub

---

हेडर कॉलम ("TEST TABLE") पर क्लिक करने से सूची 2 भागों में फ़िल्टर हो जाएगी

भाग 1:

• वर्तमान स्तंभ के सभी कक्षों से आइटम को शीट के पहले अप्रयुक्त स्तंभ में निकालें
• Excel TRIM () फ़ॉर्मूला (क्लिपबोर्ड का उपयोग करके कॉपी-अतीत नहीं) का उपयोग करके सभी आइटम ट्रिम करें
• सूची से डुप्लिकेट निकालें: .RemoveDuplicates Columns:=1, Header:=xlNo
• आइटम को क्रमबद्ध करें (प्रत्येक कक्ष में शब्द अभी तक अलग नहीं हुए हैं)
• अल्पविराम द्वारा अलग किए गए सभी स्ट्रिंग वाले एक स्ट्रिंग बनाएं

भाग 2:

• स्ट्रिंग को फिर से विभाजित करें
• सभी आइटम ट्रिम करें (सेल शब्द अब अलग हो सकते हैं जिसमें अतिरिक्त स्थान हो सकते हैं)
• सूची से डुप्लिकेट निकालें और उन्हें एक बार फिर से सॉर्ट करें
• फ़िल्टर्ड सूची युक्त एक अंतिम स्ट्रिंग बनाएं
• अंतिम आइटम के साथ कॉम्बो बॉक्स ड्रॉप-डाउन अपडेट करें

जब उपयोगकर्ता ड्रॉप-डाउन सूची से किसी आइटम का चयन करता है

• यह आंशिक पाठ वाले कक्षों के लिए एक ऑटोफ़िल्टर प्रदर्शन करेगा

  • Criteria1:="*" & fltrCriteria & "*", (Ex "* test3 *" )

• बटन क्लियर सॉर्ट ऑटोफिल्टर को हटाता है

• फ़िल्टर को हटाए बिना बटन रद्द करना फ़ॉर्म को बंद कर देता है

• एक बार फॉर्म बंद होने के बाद, फ़िल्टर को 3 तरीके से हटाया जा सकता है

  • ऑटोफिल्टर ड्रॉप-डाउन और "सभी का चयन करें" का उपयोग करते हुए मानक तरीका
  • मेनू डेटा टैब और फ़िल्टर बटन पर क्लिक करें
  • कॉलम हेडर पर फिर से क्लिक करना (टेस्ट टेबल)

---

फ़िल्टर्ड ड्रॉप-डाउन सूची:

मानदंड "test3" का उपयोग करके फ़िल्टर की गई पंक्तियाँ

पिछला फ़िल्टर साफ़ करें: