excelvbafilter

I would like to filter rows wherein it's identical in 1 column and there must be no other combinations in 2 other columns


This is a link to my post in another place just in-case I get told that I am cross posting. ( https://www.mrexcel.com/board/threads/filtering-a-column-that-is-unique-in-2-columns-with-no-other-combinations.1273902/#post-6273193 )

I am very much a beginner in Excel VBA. So far, I have learned a lot, but I'm stuck in this one problem. I'm sorry I cannot post a sample spreadsheet due to privacy reasons (And it's all in Japanese). I want to be able to filter a row of data wherein it may or may not have multiple entries in Column G, but it must have identical data in Column C and column E.

This photo for example.

This means I can filter 'Ms.LLL' since there's only one existing combination. And if I try to filter 'Mr.MMM', it should give an error that "There are conflicting stores for this buyer."

I'm sorry for the trouble, but can anyone help me gain some light in this? I thank you all in advance.

I have been thinking of 'CountIfs' and 'Unique' for the 2 columns that I need as my criteria, so I have been doing trial and error on that for a while.

    Dim WORK_SHEET As Worksheet
    Dim UNIRANGE_ONE, UNIRANGE_TWO As Range
    Dim COUNT_RANGE As Range
    Dim UNIQUE_VALUES As Collection
    Dim CELL As Range
    Dim CRIT_ONE, CRIT_TWO As String
    Dim COUNT_RESULT As Long
    
    Set WORK_SHEET = ThisWorkbook.ActiveSheet
    Set UNIRANGE_ONE = WORK_SHEET.Range("C:C")
    Set UNIRANGE_TWO = WORK_SHEET.Range("E:E")
    
    Set COUNT_RANGE = WORK_SHEET.Range("G:G")
    
    Set UNIQUE_VALUES = New Collecton
    For Each CELL In UNIRANGE_ONE
        UNIQUE_VALUES.Add CELL.Value, CStr(CELL.Value)
    Next CELL
    On Error GoTo 0
    
    For Each CELL In UNIQUE_VALUES
        COUNT_RESULT = Application.WorksheetFunction.CountIfs(UNIRANGE_ONE,    UNIRANGE_TWO, CELL, COUNT_RANGE)
       Next CELL
    
    'For Each END_USER In ListRange
    'UniqueValues.Add CellValue, CStr(Cells(AROW, 7).Value)
    'Next
    'ENDUSER_COUNT = UniqueValues.Count

Solution

  • Here's corrected code using dictionary to store information, more closely to what you have right now and maybe good for educational purposes:

    Sub FilterBuyerWithMatchingStoreInfo()
        Dim ws As Worksheet
        Dim lastRow As Long
        Dim dict As Object
        Dim buyer As String
        Dim i As Long
        Dim uniquePair As String
        Dim pairsDict As Object
        Dim selectedBuyer As String
        Dim inputFound As Boolean
        
        Set ws = ThisWorkbook.ActiveSheet
        lastRow = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row
        
        Set dict = CreateObject("Scripting.Dictionary")
        
        ' Build dictionary: Buyer -> Collection of "ColC|ColE" values
        For i = 2 To lastRow ' Assuming headers in row 1
            buyer = Trim(ws.Cells(i, "G").Value)
            If buyer <> "" Then
                uniquePair = ws.Cells(i, "C").Value & "|" & ws.Cells(i, "E").Value
                If Not dict.exists(buyer) Then
                    Set pairsDict = CreateObject("Scripting.Dictionary")
                    dict.Add buyer, pairsDict
                End If
                dict(buyer)(uniquePair) = 1
            End If
        Next i
        
        ' Ask user which buyer to filter
        selectedBuyer = InputBox("Enter Buyer name to filter (from Column G):")
        If selectedBuyer = "" Then Exit Sub
        
        inputFound = dict.exists(selectedBuyer)
        
        If Not inputFound Then
            MsgBox "Buyer '" & selectedBuyer & "' not found.", vbExclamation
            Exit Sub
        End If
        
        ' Check how many unique C|E pairs the buyer has
        If dict(selectedBuyer).Count > 1 Then
            MsgBox "There are conflicting stores for this buyer.", vbCritical
            Exit Sub
        End If
        
        ' Clear previous filters
        If ws.AutoFilterMode Then ws.AutoFilter.ShowAllData
        
        ' Apply filter on Column G for the selected buyer
        ws.Range("A1").AutoFilter Field:=7, Criteria1:=selectedBuyer ' Column G is field 7
        
        MsgBox "Filter applied for '" & selectedBuyer & "'."
    End Sub
    

    Missing headers update

    For missing headers, you could apply following strategy:

    1. Before applying autofilter, put some temp values in the headers row for auto filter to work

    2. Apply auto filter.

    3. Clear temporary header values, to restore original state.

    In order to implement that, i could suggest

    1. declare new variables (in place where you have other declarations with Dim):

      Dim th As Variant
      Dim tempHeaders As Collection
      
    2. fill empty rows

      ' Temporarily fill missing headers and record positions
      For i = 1 To 7 ' Columns A to G
          If Trim(ws.Cells(1, i).Value) = "" Then
              ws.Cells(1, i).Value = "TempHeader" & i
              tempHeaders.Add i ' Store the column index of the header we changed
          End If
      Next i
      
    3. Apply auto filter like you do currently

    4. Clear values from temp headers after filter is applied:

      For Each th In tempHeaders
          ws.Cells(1, th).Value = ""
      Next th