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 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
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:
Before applying autofilter, put some temp values in the headers row for auto filter to work
Apply auto filter.
Clear temporary header values, to restore original state.
In order to implement that, i could suggest
declare new variables (in place where you have other declarations with Dim
):
Dim th As Variant
Dim tempHeaders As Collection
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
Apply auto filter like you do currently
Clear values from temp headers after filter is applied:
For Each th In tempHeaders
ws.Cells(1, th).Value = ""
Next th