如何将两个 excel vba 代码合并为一个捕获动态变化值的代码

Question

我有以下两个几乎相似的 excel vba 代码，但我想将它们合并为一个： 代码 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

代码 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

Answer 1

据我所知，您希望采用合理通用的代码并使其可重用。

试试这个。

在 VBA 编辑器中创建一个新模块并粘贴此代码。您在每个工作表上的代码略有变化。我添加了 Target 参数并直接引用了已更改的工作表...

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 Not sirg Is Nothing Then
        ' 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
    End If
    
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

...现在从 Worksheet_OnChange 事件方法中，执行类似的操作...

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

...这将使您的代码可重用。当然，您需要确保它完全适合您，但这是一般的想法。

Answer 2

合并相似的Worksheet_Change 代码

说明

• 对于在 A 列中手动更改的每个单元格（输入、复制/粘贴或 VBA 写入）（不包括单元格 A1）...
• ...在查找列列表中每一列的同一行（lColsList - B）...
• ...它将尝试在关联的条件列表（CriteriaList - CENTER;BOTTOM）中查找值（B）。
• 如果找到值 (B)：
  • 如果值 (B / CENTER;BOTTOM) 已经在相关目标列 (dColsList - C) 的单元格中，它将什么也不做。单元格已“密封”。
  • 如果不是，则值 (B) 将附加到单元格 (C) 由于先前的条件“密封”单元格。
• 如果找不到值 (B)：
  • 如果条件列表 (CENTER;BOTTOM) 中已有值，则它不会执行任何操作，因为单元格已“密封”。
  • 如果不是：
    • 如果值 (B) 已经在目标单元格 (C) 中，它将什么都不做。
    • 如果没有，值 (B) 将附加到单元格 (C)。

守则

• 调整常量部分中的值。
• 您可能想要删除 ;BOTTOM，因为它的目的只是为了说明您可以在每列中设置更多标准来“密封”（“冻结”）单元格。

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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 = "DelimitOnChange"
    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