update cell when column header matches a list

Question

I am not the greatest at Excel vba but know enough to be dangerous.

I have Sheet1 which has records with App ID(A), status(B) and a free text field(C) we use for notes which can have many carriage returns or none.

Sheet2 contains a column for a flag name (columnA) and partial text (columnB) that needs to match to Sheet 1 notes(columnC)

I have code that creates Sheet 1 from reports and then takes the list from Sheet2,Column A and uses them as headers in Sheet 1.

I have code that I've manipulated to check if any part of the text in Column B in Sheet 2 exists in Column C in Sheet1 and if it does, mark column D in Sheet1 with a "1". The code works but I am needing to match up to the column names in Sheet 1 and update the appropriate column/flag. I've attached pictures to help show what I am needing and below is my code to date.

Sub Test()

Dim w1 As Worksheet
Dim w2 As Worksheet
Dim c As Range
Dim r As Range

Application.ScreenUpdating = False

Set w1 = Worksheets("sheet1")
Set w2 = Worksheets("sheet2")

For Each c In w2.Range("B2", w2.Range("B" & Rows.Count).End(xlUp)) 'loop through B
    Set r = w1.Columns(3).Find(What:=c.Value, LookIn:=xlFormulas, Lookat:=xlPart, MatchCase:=False, SearchFormat:=False)
    If Not r Is Nothing Then  'found in B
        w1.Range("E" & r.Row).Value = 1 'Update value to 1 if found.
    End If
Next c

Application.ScreenUpdating = True
    
    End Sub

taller · Accepted Answer

The 1st Dictionary object is used to store NI reason col index on Sheet1.
The 2nd Dictionary object is used to store NI reason and trigger text.

Option Explicit
Sub Demo()
    Dim objDic1 As Object, objDic2 As Object
    Dim rngData As Range, vKey
    Dim i As Long, sKey As String, sReason As String
    Dim arrData
    Const COL_START = 4 ' the 1st NI reason col on Sheet1
    Set objDic1 = CreateObject("scripting.dictionary")
    Set objDic2 = CreateObject("scripting.dictionary")
    ' Load data from Sheet2
    arrData = Sheets("sheet2").Range("A1").CurrentRegion
    For i = LBound(arrData) + 1 To UBound(arrData)
        sKey = arrData(i, 2)
        If Not objDic2.exists(sKey) Then
            objDic2(sKey) = arrData(i, 1)
        End If
    Next i
    ' Load data from Sheet1
    Set rngData = Sheets("sheet1").Range("A1").CurrentRegion
    arrData = rngData.Value
    For i = 4 To UBound(arrData, 2)
        sKey = arrData(1, i)
        If Not objDic1.exists(sKey) Then
            objDic1(sKey) = i
        End If
    Next i
    ' Populate the data
    For i = LBound(arrData) + 1 To UBound(arrData)
        sKey = arrData(i, 3)
        For Each vKey In objDic2.Keys
            If InStr(1, sKey, vKey, vbTextCompare) > 0 Then
                sReason = objDic2(vKey)
                If objDic1.exists(sReason) Then
                    arrData(i, objDic1(sReason)) = 1
                End If
            End If
        Next
    Next i
    rngData.Value = arrData
End Sub

Microsoft documentation:

InStr function

Dictionary object

update cell when column header matches a list

Answers (2)

Related Questions