Check whether array is a subset of another array

[fxrexcel]

I have the following problem. I have a Column "Data" and a column "Criteria" and I want to replace the cells of "Data" with "#N/A" based on:

• if cell of "Data" is a equal to one of the criteria, then replace
• if cell of "Data" is a subset of the criteria, then replace
• if cell of "Data" is not a complete subset of the criteria, e.g. "AAA, CCC" (i.e. CCC is not in "Criteria"), then do not replace

[TABLE="width: 100"]
<tbody>[TR]
[TD]Criteria[/TD]
[/TR]
[TR]
[TD]AAA[/TD]
[/TR]
[TR]
[TD]BBB[/TD]
[/TR]
[TR]
[TD]DDD[/TD]
[/TR]
[TR]
[TD]...[/TD]
[/TR]
[TR]
[TD]...[/TD]
[/TR]
</tbody>[/TABLE]


Before:

[TABLE="width: 100"]
<tbody>[TR]
[TD]Data[/TD]
[/TR]
[TR]
[TD]AAA[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]BBB, AAA[/TD]
[/TR]
[TR]
[TD]CCC[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]DDD, BBB[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]AAA, CCC[/TD]
[/TR]
[TR]
[TD]CCC[/TD]
[/TR]
</tbody>[/TABLE]

Before:

[TABLE="width: 100"]
<tbody>[TR]
[TD]Data[/TD]
[/TR]
[TR]
[TD]#N/A[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]#N/A[/TD]
[/TR]
[TR]
[TD]CCC[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]#N/A[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]AAA, CCC[/TD]
[/TR]
[TR]
[TD]CCC[/TD]
[/TR]
</tbody>[/TABLE]


What I am trying to do: I transformed "Criteria" into an array arrCriteria = {AAA;BBB;CCC;...}. Then I go to the data column, loop through it and each cell. If the cell is empty, then I don't need to do anything. If I found a comma in a data cell, then I need to check whether that cell is a full subset of arrCriteria (e.g. "AAA, BBB" or "CCC, BBB"). Then I will need a statement if there is only one entry, e.g. only "AAA", "BBB", "CCC"...

Here is what I have so far:

Sub SubsetArray()

    lastRow = Criteria.Cells(Rows.Count, "D").End(xlUp).Row


    Dim txt As String
    
    Dim FullName As Variant
    Dim cell As Range
    Dim j As Long
    Dim k As Long
    Dim l As Long
    Dim data As Worksheet
    Dim Criteria As Worksheet
    
    Set data = ThisWorkbook.Sheets("PBEXP")
    Set Criteria = ThisWorkbook.Sheets("Verticals")


    arrCriteria = Join(Application.Transpose(Criteria.Range("D2:D" & lastRow).value), "#")
  
    Deleteme = Split(arrCriteria, "#")


    lastRow = data.Cells(Rows.Count, "B").End(xlUp).Row
      
    On Error Resume Next
    
    For Each cell In data.Range(data.Cells(2, 10), data.Cells(lastRow, 10))
    
        txt = cell.value ' current cell content
        
        ' If cell is empty, then do nothing
        If IsEmpty(txt) Then ' if cell is empty then skip
    
        ' If a comma is found, then check if subset is found
        ElseIf InStr(1, txt, ", ") > 0 Then
        
              FullName = Split(txt, ", ") ' split cell content into array txt
    
              For j = LBound(FullName) To UBound(FullName)
                  For k = LBound(Deleteme) To UBound(Deleteme)
                
                      If FullName(j) <> Deleteme(k) Then
                                                                                                       
                      Else if FullName(j) = Deleteme(k) then
                          
                      data.Columns("J").Replace txt, "#N/A", xlWhole, , False, False, False
                     
                      End If
                     
                  Next k
              Next j
        End If
        
    Next cell
    
  End Sub

 

[Fluff]

How about

Sub SubsetArray()
   Dim Txt As Variant
   Dim Flg As Boolean
   Dim Cl As Range
   Dim Lr As Long, i As Long
   Dim data As Worksheet
   Dim Criteria As Worksheet
   
   Set data = ThisWorkbook.Sheets("PBEXP")
   Set Criteria = ThisWorkbook.Sheets("Verticals")
   Lr = Criteria.Cells(Rows.Count, "D").End(xlUp).Row

   With CreateObject("scripting.dictionary")
      For Each Cl In Criteria.Range("D2:D" & Lr)
         .Item(Cl.Value) = Empty
      Next Cl
      Lr = data.Cells(Rows.Count, "B").End(xlUp).Row
      For Each Cl In data.Range("J2:J" & Lr)
         If Not IsEmpty(Cl) Then
            Txt = Split(Cl.Value, ", ")
            For i = 0 To UBound(Txt)
               If .exists(Txt(i)) Then Flg = True Else Flg = False
            Next i
            If Flg Then Cl.Value = "#N/A"
         End If
      Next Cl
   End With
  End Sub

 

[fxrexcel]

Amazing! You're the best, thanks!

 

[Fluff]

Glad to help & thanks for the feedback

 

[fxrexcel]

Hi Fluff,

I checked it a bit more in detail and the code seems not yet to do exactly what I need.

It manages to replace the cells with #N/A that have just one of the following: AAA, BBB, DDD E.g. if cell = "AAA", then it's #N/A.

It also manages to replace cells with that have a combination of them. E.g. if cell = "AAA, BBB" or "DDD, AAA, BBB", then it's #N/A.

Now, if the cell has an entry "XXX, YYY, AAA", then it is also deleted. So, it is dependent on the order at the moment:

"XXX, YYY, AAA": would be deleted, but has to stay in the list
"AAA, XXX, YYY": would not be deleted currently, but also has to stay in the list

Also, for almost all empty cells it does not put an "#N/A" but for a small fraction it does.

Thanks for your help!

 

[fxrexcel]

About the "Also, for almost all empty cells it does not put an "#N/A" but for a small fraction it does.": I found what happens.

If (1) in the previous cell the code found e.g. "AAA", one that is replaced by "#N/A" and (2) the next cells are empty, then the code writes "#N/A" in them as well, whereas these should remain empty.

 

[Fluff]

Ok, how about

Sub SubsetArray()
   Dim Txt As Variant
   Dim Flg As Long
   Dim Cl As Range
   Dim lr As Long, i As Long
   Dim data As Worksheet
   Dim Criteria As Worksheet
   
   Set data = ThisWorkbook.Sheets("PBEXP")
   Set Criteria = ThisWorkbook.Sheets("Verticals")
   lr = Criteria.Cells(Rows.Count, "D").End(xlUp).Row

   With CreateObject("scripting.dictionary")
      For Each Cl In Criteria.Range("D2:D" & lr)
         .Item(Cl.Value) = Empty
      Next Cl
      lr = data.Cells(Rows.Count, "B").End(xlUp).Row
      For Each Cl In data.Range("J2:J" & lr)
         If Not IsEmpty(Cl) Then
            Txt = Split(Cl.Value, ", ")
            For i = 0 To UBound(Txt)
               If .Exists(Txt(i)) Then Flg = Flg + 1
            Next i
            If Flg = UBound(Txt) + 1 Then Cl.Value = "#N/A"
            Flg = 0
         End If
      Next Cl
   End With
End Sub

If it's putting #N/A into an empty cell , then the cell probably isn't empty

 

[fxrexcel]

Thanks. Now, it's independent of the order. So that is all good. Just the empty cells are causing troubles.

Before it was:

If (1) in the previous cell the code found e.g. "AAA", one that is replaced by "#N/A" and (2) the next cells are empty, then the code writes "#N/A" in them as well, whereas these should remain empty.

Now it is reversed:

If (1) in the previous cell did not find a subset, e.g. the cell is "XXX" and (2) the next cells are empty, it now writes "#N/A" in them.

All cells are empty, no space or anything. I think just a slight tweak in the code will do it, it seems to remember what do to until it finds a next cell that is non-empty.

 

[Fluff]

If I start with

Excel 2013/2016
	K
1
2	AAA
3
4	BBB, AAA
5	CCC
6
7	DDD, BBB
8
9	AAA, CCC
10	CCC, AAA
11
12	XXX
13
14	DDD
15
16	DDD, AAA
PBEXP

I end up with

Excel 2013/2016
	J
1
2	#N/A
3
4	#N/A
5	CCC
6
7	#N/A
8
9	AAA, CCC
10	CCC, AAA
11
12	XXX
13
14	#N/A
15
16	#N/A
PBEXP

Try using this & point to an empty cell that is turning to #N/A
=ISBLANK(J3)
What does it say

 

[fxrexcel]

Ok, thanks. That's the problem, some of the cells are not blank although they appear empty. Is it possible to loop through the empty cells in the column and make them blank?