Otdfbt

Let's say I have a list containing different sized sublists of string pairs structured like this

"A", "B", "C", "D", "E", "D", "G","B", "H", "B", "I", "B"

where the first and second sublists each contain two string pairs and the third and fourth sublists each contain 1 string pair.

I want to get rid of every string pair where the second string of the string pair does not appear in each sublist. For example, there exists string pairs in each sublist where the second string of the string pair is "B". Thus, I only want to keep those string pairs. The final list should look like this

"A", "B", "G","B", "H", "B", "I", "B"

Although each of the first two sublists contain a pair of strings where there is a "D" in the second element, these need to be removed since there aren't string pairs containing "D"'s in the second element of the string pairs in the third and fourth sublists.

I would like for this function to work no matter the number of sublists and no matter the number of elements contained in those sublists. I know how to do this if the list was completely flattened, but it is not in this case. There is no need for this to be an efficient process, so anything that can produce these results would be helpful. Any ideas?

I assume that it's always the second element that determines sublist eligibility:

L = "A", "B", "C", "D", "E", "D", "G", "B", "H", "B", "I", "B";

Cases[_, Alternatives @@ Intersection @@ L[[All, All, 2]], ___] /@ L

"A", "B", "G", "B", "H", "B", "I", "B"

If instead it's always the last element, then the pattern would be

Cases[___, Alternatives @@ Intersection @@ L[[All, All, -1]]] /@ L

"A", "B", "G", "B", "H", "B", "I", "B"

Using GroupBy and KeyIntersection:

ClearAll[f1]
f1 = Apply[Join]@*Values@*KeyIntersection@*Map[GroupBy[Last]];

lst = "A", "B", "C", "D", "E", "D", "G", "B", "H", "B", "I", "B";
f1 @ lst

"A", "B", "G", "B", "H", "B", "I", "B"

DeleteCases seems to be faster:

ClearAll[f2]
f2 = DeleteCases[#, Except@___, Alternatives @@ Intersection @@ #[[All, All, -1]], 2]&;

f2 @ lst

"A", "B", "G", "B", "H", "B", "I", "B"

list="A","B","C","D","E","D","G","B","H","B","I","B"; 

List/@Select[Flatten[list,1],MemberQ[Last@@@Select[list,Length@#==1&],#[[2]]]&] 

"A", "B", "G", "B", "H", "B", "I", "B"

a = "A", "B", "C", "D", "E", "D", "G", "B", "H","B", "I", "B"
f = Select[ContainsAny[Intersection @@ Union @@@ #]@*List@*Last] /@ # &;

f[a]

"A", "B", "G", "B", "H", "B", "I", "B"