Record dynamically changing values in excel-CodePudding

In excel, I have a column A which will have changing values like 12,15,19,25 etc. and based on that a formula will run in column B which will have only 5 values, lets say TOP, RIGHT, LEFT, BOTTOM, CENTER. I want the column C to capture the changing values in column B. Which means Column C will look like - TOP, TOP, RIGHT, TOP, LEFT, LEFT, BOTTOM, TOP, LEFT and so on. Also whenever the formula in column B gives output CENTER, column C should also have CENTER and after that the macro should stop automatically and column C should not record any more values. I know it is complex but I will be grateful if anyone can solve it. Below is the code I have tried in macro:

Private Sub Worksheet_Change(ByVal Target As Range)
   
        Application.EnableEvents = False
      
          With Range("C" & Target.Row)

            .Value = .Value & ","
 
        .Value = .Value & Range("B" & Target.Row).Value
         End With
        Application.EnableEvents = True
    
End Sub

CodePudding user response：

A Worksheet Change

When values in rows of column A are manually changed, the strings in the same rows of column B, changed by a formula, will be appended, using a comma as the delimiter, to the strings in the same rows of column C, unless the right part of the string in column C is equal to CENTER.
Adjust the values in the constants section. A2 assumes that your data has headers in A1:C1.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   
    On Error GoTo ClearError
    
    Const sfCellAddress As String = "A2" ' source
    Const lCol As String = "B" ' lookup
    Const dCol As String = "C" ' destination
    Const Criteria As String = "CENTER"
    
    Dim sfCell As Range: Set sfCell = Range(sfCellAddress)
    Dim srg As Range: Set srg = sfCell.Resize(Rows.Count - sfCell.Row   1)
    
    Dim sirg As Range: Set sirg = Intersect(srg, Target)
    
    If sirg Is Nothing Then Exit Sub
        
    ' Relevant Ranges (lcol, dcol)
    Dim lrg As Range: Set lrg = Intersect(sirg.EntireRow, Columns(lCol))
    Dim drg As Range: Set drg = Intersect(sirg.EntireRow, Columns(dCol))
    
    Dim cLen As Long: cLen = Len(Criteria)
    
    Dim lString As String
    Dim dString As String
    Dim r As Long
    
    Application.EnableEvents = False
    
    For r = 1 To lrg.Cells.Count
        lString = CStr(lrg.Cells(r).Value)
        If Len(lString) > 0 Then
            dString = CStr(drg.Cells(r).Value)
            If StrComp(Right(dString, cLen), Criteria, vbTextCompare) <> 0 Then
                If Len(dString) = 0 Then
                    dString = lString
                Else
                    dString = dString & "," & lString
                End If
                drg.Cells(r).Value = dString
            End If
        End If
    Next r
    
SafeExit:
    If Not Application.EnableEvents Then
        Application.EnableEvents = True
    End If
    
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub

EDIT:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   
    On Error GoTo ClearError
    
    Const sfCellAddress As String = "A2" ' source
    Const lCol As String = "B" ' lookup
    Const dCol As String = "C" ' destination
    Const CriteriaList As String = "CENTER,SURFACE"
    Const Delimiter As String = ","
    
    Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
    Dim cUpper As Long: cUpper = UBound(Criteria)
    
    Dim sfCell As Range: Set sfCell = Range(sfCellAddress)
    Dim srg As Range: Set srg = sfCell.Resize(Rows.Count - sfCell.Row   1)
    
    Dim sirg As Range: Set sirg = Intersect(srg, Target)
    
    If sirg Is Nothing Then Exit Sub
        
    ' Relevant Ranges (lcol, dcol)
    Dim lrg As Range: Set lrg = Intersect(sirg.EntireRow, Columns(lCol))
    Dim drg As Range: Set drg = Intersect(sirg.EntireRow, Columns(dCol))
    
    Dim lString As String
    Dim dString As String
    Dim c As Long
    Dim cIndex As Variant
    Dim r As Long
    
    Application.EnableEvents = False
    
    For r = 1 To lrg.Cells.Count
        lString = CStr(lrg.Cells(r).Value)
        Debug.Print Len(lString)
        If Len(lString) > 0 Then
            dString = CStr(drg.Cells(r).Value)
            If Len(dString) = 0 Then
                dString = lString
            Else
                For c = 0 To cUpper
                    If StrComp(Right(dString, Len(Criteria(c))), _
                            Criteria(c), vbTextCompare) = 0 Then Exit For
                Next c
                If c > cUpper Then
                    If InStr(1, dString, lString, vbTextCompare) = 0 Then
                        dString = dString & Delimiter & lString
                    End If
                End If
            End If
            drg.Cells(r).Value = dString
        End If
    Next r
                
SafeExit:
    If Not Application.EnableEvents Then
        Application.EnableEvents = True
    End If
    
    Exit Sub
ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit
End Sub