How can I merge two excel vba code into one which captures dynamically changing values-CodePudding

I have the below two excel vba codes which are almost alike but I want to merge them into one: Code 1:

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

Code 2

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   
    On Error GoTo ClearError
    
    Const sfCellAddress As String = "A2" ' source
    Const lCol As String = "D" ' lookup
    Const dCol As String = "E" ' destination
    Const Criteria As String = "SURFACE"
    
    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

CodePudding user response：

From what I can work out, you want to take the reasonably generic code and make it reusable.

Try this.

Create a new module in the VBA editor and paste this code. It's a slight change on the code you had on each worksheet. I've added the Target parameter and referred directly to the worksheet that was changed ...

Public Sub OnSheetChange(ByVal Target As Range, ByVal sfCellAddress As String, ByVal lCol As String, _
        ByVal dCol As String, ByVal Criteria As String)
        
    On Error GoTo ClearError
    
    Dim objSheet As Worksheet
    Set objSheet = Target.Worksheet
    
    Dim sfCell As Range: Set sfCell = objSheet.Range(sfCellAddress)
    Dim srg As Range: Set srg = sfCell.Resize(objSheet.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, objSheet.Columns(lCol))
    Dim drg As Range: Set drg = Intersect(sirg.EntireRow, objSheet.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

... now from each Worksheet_OnChange event method, do something like this ...

Private Sub Worksheet_Change(ByVal Target As Range)
    OnSheetChange Target, "A2", "B", "C", "CENTER"
End Sub

... and ...

Private Sub Worksheet_Change(ByVal Target As Range)
    OnSheetChange Target, "A2", "D", "E", "SURFACE"
End Sub

... that will make your code reusable. Naturally, you will need to make sure it works perfectly for you but that's the general idea.

CodePudding user response：

Merging Similar `Worksheet_Change` Codes

Description

For each cell manually changed (enter, copy/paste or VBA write) in column A (cell A1 excluded)...
... in the same row of each column in the lookup columns list (lColsList - B) ...
... it will try to find the value (B) in the associated criteria list (CriteriaList - CENTER;BOTTOM).
If the value (B) is found:
- If the value (B / CENTER;BOTTOM) is already in the cell of the associated destination column (dColsList - C) it will do nothing. The cell is 'sealed'.
- If not, the value (B) will be appended to the cell (C) 'sealing' the cell due to the previous condition.
If the value (B) is not found:
- If there already is a value from the criteria list (CENTER;BOTTOM) it will do nothing since the cell is 'sealed'.
- If not:
  - If the value (B) is already in the destination cell (C), it will do nothing.
  - If not, the value (B) will be appended to the cell (C).

The Code

Adjust the value in the constants section.
You may want to remove ;BOTTOM since its purpose is just to illustrate that you can have more criteria per column to 'seal' ('freeze') a cell.

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Calls:        Worksheet_Change
'                   DelimitOnChange
'                       DelimitOnChangeWrite
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    DelimitOnChange Target
End Sub

Private Sub DelimitOnChange( _
        ByVal Target As Range)

    Const ProcName As String = "CreateDelimitedList"
    On Error GoTo ClearError
    
    Const sfCellAddress As String = "A2" ' source
    Const lColsList As String = "B,D" ' lookup
    Const dColsList As String = "C,E" ' destination
    Const CriteriaList As String = "CENTER;BOTTOM,SURFACE"
    Const ListDelimiter As String = "," ' 3 lists (see right above)
    Const CriteriaDelimiter As String = ";" ' multiple criteria per column
    Const ValuesDelimiter As String = "," ' values in lookup column
    
    Dim srg As Range
    With Target.Worksheet
        Dim sfCell As Range: Set sfCell = .Range(sfCellAddress)
        Set srg = sfCell.Resize(.Rows.Count - sfCell.Row   1)
    End With
    
    Dim sirg As Range: Set sirg = Intersect(srg, Target)
    If sirg Is Nothing Then Exit Sub
        
    Dim lCols() As String: lCols = Split(lColsList, ListDelimiter)
    Dim dCols() As String: dCols = Split(dColsList, ListDelimiter)
    Dim Criteria() As String: Criteria = Split(CriteriaList, ListDelimiter)
        
    Application.EnableEvents = False
    
    Dim n As Long
    For n = 0 To UBound(lCols)
        DelimitOnChangeWrite sirg, lCols(n), dCols(n), Criteria(n), _
            CriteriaDelimiter, ValuesDelimiter
    Next n
                
SafeExit:
    If Not Application.EnableEvents Then
        Application.EnableEvents = True
    End If
    
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume SafeExit
End Sub

Private Sub DelimitOnChangeWrite( _
        ByVal sirg As Range, _
        ByVal lCol As String, _
        ByVal dCol As String, _
        ByVal CriteriaList As String, _
        Optional ByVal CriteriaDelimiter As String = ";", _
        Optional ByVal ValuesDelimiter As String = ",")
    Const ProcName As String = "DelimitOnChangeWrite"
    On Error GoTo ClearError

    Dim Criteria() As String: Criteria = Split(CriteriaList, CriteriaDelimiter)
    Dim cUpper As Long: cUpper = UBound(Criteria)

    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
    
    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 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 & ValuesDelimiter & lString
                    End If
                End If
            End If
            drg.Cells(r).Value = dString
        End If
    Next r
                
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Sub

Merging Similar Worksheet_Change Codes

Merging Similar `Worksheet_Change` Codes