Excel VBA: Compare Delimited String in Cell to Column of Values

user_5429130 0
Viewed 419

I have a list of (semi-colon delimited) genes within column B I want to create from that list, a list of the genes which are found in Column A. 

| Keep             | List                       |   | Result      |
|------------------|----------------------------|---|-------------|
| AASS;SESN1;SEPT5 | AASS                       |   | AASS        |
|                  | ARMC2;SESN1;ARMC2AS1;SEPT5 |   | SESN1;SEPT5 |
|                  |                            |   |             |

I have a start on a code, but it only appears to work for some of the gene lists, but not all.

For example, the lists in cells B2 and B3 are extracted to Column C correctly, but cell B4 ends up with 7 extra terms (but running the VBA Script a second time results in the correct number & composition), and B5 results in a strange output "4;5;0;2;3;1;SNORD1161" in D5.

This the code that I have so far, and it was modified from: https://www.mrexcel.com/forum/excel-questions/654920-match-comma-delimited-values-cell-against-individual-values-column.html

Any help would be appreciated! Thanks!

Sub matchups2()

    Dim regex_leading As New VBScript_RegExp_55.RegExp
    Dim regex_middle As New VBScript_RegExp_55.RegExp
    Dim regex_trailing As New VBScript_RegExp_55.RegExp

    Set d = CreateObject("scripting.dictionary")
    For Each gene In Range("A2", Cells(Rows.Count, "A").End(3)).Value
        d(gene) = 1
    Next gene
    Stop

    For Each genelist In Range("B2", Cells(Rows.Count, "B").End(3))
        c = genelist.Value
        k = genelist.Row

        For Each q In Split(c, ";")
            If d(q) <> 1 Then
                c = Replace(c, q, ";")
            End If
        Next q

        regex_leading.Pattern = "^;{1,}"
        With regex_middle
            .Pattern = ";{1,}"
            .Global = True
        End With
        regex_trailing.Pattern = ";{1,}$"

        c = regex_leading.Replace(c, "")
        c = regex_middle.Replace(c, ";")
        c = regex_trailing.Replace(c, "")

        Cells(k, "D").Value = c
    Next genelist

End Sub
vba excel
1 Answers

I think this should work for you.

Sub GenesDict()

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    'add A genes to dictionary
    Dim i As Long
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Dim temp As Variant
        temp = Split(Cells(i, "A").Value2, ";")

        Dim j As Long
        For j = LBound(temp) To UBound(temp)
            dict.Add Trim(temp(j)), "text"
        Next j
    Next i

    'clear D
    Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row).ClearContents

    'transfer from B to D only genes in A
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        temp = Split(Cells(i, "B").Value2, ";")

        For j = LBound(temp) To UBound(temp)
            If dict.exists(Trim(temp(j))) Then
                Cells(i, "D").Value2 = Cells(i, "D").Value2 & Trim(temp(j)) & ";"
            End If
        Next j

        'remove trailing ";"
        If Right(Cells(i, "D").Value2, 1) = ";" Then
            Cells(i, "D").Value2 = Left(Cells(i, "D").Value2, Len(Cells(i, "D").Value2) - 1)
        End If

    Next i

End Sub
user_27274370
Related