Search code examples
excelvba

Change value in cell based on partial string match from list plus extra condition

I am using the following macro in excel to change the value in a column from "0" to "1" if a cell in the same row has a partial string match to a list of partial strings.

Example of tables in excel:

Item Number Description On Sale
123 Apple 1
456 Orange (Sale) 1
456 Orange 0
789 Banana 1
Items on Sale
Apple
Banana
Sale

I would like to add an extra condition so that is a special number exists in the row, "Sale" must be present in the description for the item to be listed as a "1".

Example of tables in excel:

Item Number Special Number Description On Sale
123 Apple 1
456 111 Special Apple 0
789 Orange 0
010 222 Special Orange (Sale) 1
011 Banana 1
Items on Sale
Apple
Banana
Sale

Below is the macro I am currently using:

Option Explicit
Sub ChangeBool()
Dim i As Long, j As Long
Dim arrData, arrDataF, rngData As Range, rngDataF As Range
Set rngData = ActiveSheet.Range("B2").CurrentRegion
Set rngDataF = ActiveSheet.Range("F2").CurrentRegion
arrData = rngData.Value
arrDataF = rngDataF.Value
For i = LBound(arrData) + 1 To UBound(arrData)
    arrData(i, 3) = 0
    For j = LBound(arrDataF) + 1 To UBound(arrDataF)
        If InStr(1, arrData(i, 2), arrDataF(j, 1), vbTextCompare) > 0 Then
            arrData(i, 3) = 1
            Exit For
        End If
    Next j
Next i
rngData.Value = arrData
End Sub
Solution
    • Add a If clause to check Special Number and Sale
    • Assuming the table starts from row 2 as your previous post
    Option Explicit

Sub ChangeBool()
    Dim i As Long, j As Long
    Dim arrData, arrDataF, rngData As Range, rngDataF As Range
    Const KEYWORD = "Sale"
    Set rngData = ActiveSheet.Range("A2").CurrentRegion
    Set rngDataF = ActiveSheet.Range("F2").CurrentRegion
    arrData = rngData.Value
    arrDataF = rngDataF.Value
    For i = LBound(arrData) + 1 To UBound(arrData)
        arrData(i, 4) = 0
        For j = LBound(arrDataF) + 1 To UBound(arrDataF)
            If InStr(1, arrData(i, 3), arrDataF(j, 1), vbTextCompare) > 0 Then
                If Len(arrData(i, 2)) = 0 Or (Len(arrData(i, 2)) > 0 And InStr(1, arrData(i, 3), KEYWORD, vbTextCompare) > 0) Then
                    arrData(i, 4) = 1
                    Exit For
                End If
            End If
        Next j
    Next i
    rngData.Value = arrData
End Sub

    Note: Testing data (the last one in Items on Sale) is different with your post.

    enter image description here

    Update:

    • Col index is defined as consts, it is easy to maintain if your table layout is changed in future.
    Sub ChangeBool()
    Dim i As Long, j As Long
    Dim arrData, arrKeyWord, rngData As Range, rngDataF As Range
    Const KEYWORD = "Sale"
    ' Modify as needed
    Const SPE_NUM_COL = 3   'Col C
    Const DES_COL = 11      ' Col K
    Const ONSALE_COL = 15   ' Col O
    Set rngData = ActiveSheet.Range("A2").CurrentRegion
    ' Assume Items on Sale is on Col Q
    Set rngDataF = ActiveSheet.Range("Q2").CurrentRegion
    arrData = rngData.Value
    arrKeyWord = rngDataF.Value
    For i = LBound(arrData) + 1 To UBound(arrData)
        arrData(i, ONSALE_COL) = 0
        For j = LBound(arrKeyWord) + 1 To UBound(arrKeyWord)
            If InStr(1, arrData(i, DES_COL), arrKeyWord(j, 1), vbTextCompare) > 0 Then
                If Len(arrData(i, SPE_NUM_COL)) = 0 Or (Len(arrData(i, SPE_NUM_COL)) > 0 And InStr(1, arrData(i, DES_COL), KEYWORD, vbTextCompare) > 0) Then
                    arrData(i, ONSALE_COL) = 1
                    Exit For
                End If
            End If
        Next j
    Next i
    rngData.Value = arrData
End Sub