在excel中記錄動態變化的值

在 excel 中，我有一個 A 列，它的值會不斷變化，例如 12,15,19,25 等，并且基于此公式將在 B 列中運行，該列只有 5 個值，比如TOP、RIGHT、LEFT、BOTTOM ，中心。我希望 C 列捕獲 B 列中不斷變化的值。這意味著 C 列看起來像 - TOP、TOP、RIGHT、TOP、LEFT、LEFT、BOTTOM、TOP、LEFT 等。此外，無論何時 B 列中的公式給出輸出 CENTER，C 列也應該有 CENTER，然后宏應該自動停止并且 C 列不應再記錄任何值。我知道這很復雜，但如果有人能解決它，我將不勝感激。以下是我在宏中嘗試過的代碼：

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

uj5u.com熱心網友回復：

作業表更改

• 當A手動更改column 行中的值時， column相同行中的字串B，通過公式更改，將使用逗號作為分隔符附加到 column 相同行中的字串C，除非右側部分列中的字串C等于CENTER。
• 調整常量部分中的值。A2假設您的資料在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

編輯：

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

標籤：擅长 vba

上一篇：即使Application.EnableEvents=False，Excel2019仍然顯示保存提示

下一篇：多個If/Then呼叫選項