如何將兩個excelvba代碼合并為一個捕獲動態變化值的代碼-有解無憂

我有以下兩個幾乎相同的 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

uj5u.com熱心網友回復：

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

試試這個。

在 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

...這將使您的代碼可重用。當然，您需要確保它完美地適合您，但這是總體思路。

uj5u.com熱心網友回復：

合并相似`Worksheet_Change`代碼

描述

對于列中手動更改（輸入、復制/粘貼或 VBA 寫入）的每個單元格A（單元格A1除外）...
... 在查找列串列 ( lColsList- B)中每一列的同一行...
...它將嘗試B在關聯的條件串列 ( CriteriaList- CENTER;BOTTOM) 中查找值 ( )。
如果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

轉載請註明出處，本文鏈接：https://www.uj5u.com/qiye/392501.html

標籤：擅长 vba

上一篇：如何定義DIAG函式？

下一篇：如何在aspnetcorewebAPI上正確地將串列轉換為IQueryable

如何將兩個excelvba代碼合并為一個捕獲動態變化值的代碼

合并相似Worksheet_Change代碼

合并相似`Worksheet_Change`代碼