如何将两个 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 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

...现在从每个 Worksheet_OnChange 事件方法，做这样的事情......

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

... 和...

Private Sub Worksheet_Change(ByVal Target As Range)
    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