Excel VBA技术求助：A列触发脚本及D列内容同步问题

Let's break down why your Lokation sub isn't clearing all relevant rows in column D, and fix it up properly.

What's Causing the Problem? #

• Your code uses n = Cells(Rows.Count, "A").End(xlUp).Row to get the last non-empty row in column A. This means any rows in column A that are blank after the last non-empty row won't be processed—so their corresponding D column cells stay untouched.
• The j variable is redundant and creates unnecessary complexity (you're incrementing it alongside i, which serves the same purpose as the row number).
• Running a full loop over all rows every time a single cell changes is inefficient, especially as your sheet grows.

Solution 1: Optimize the Worksheet Change Event (Recommended) #

Instead of looping every row in column A whenever a change happens, we can directly target only the row(s) that were modified in column A. This is faster and avoids the partial clearing issue entirely.

Replace your existing Worksheet_Change event and Lokation sub with this code in your worksheet's code module:

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Only react to changes in column A
    If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    On Error GoTo Finalize
    
    Dim changedRow As Range
    ' Handle cases where multiple rows are changed at once (e.g., paste)
    For Each changedRow In Intersect(Target, Me.Range("A:A"))
        With Me.Cells(changedRow.Row, "D")
            If Trim(Me.Cells(changedRow.Row, "A").Value) = vbNullString Then
                ' Clear D column if A column is empty
                .Value = vbNullString
            Else
                ' Extract 2nd-4th characters from A column to D column
                .Value = Mid(Me.Cells(changedRow.Row, "A").Value, 2, 3)
            End If
        End With
    Next changedRow
    
Finalize:
    Application.EnableEvents = True
End Sub

Solution 2: Fix the Existing Lokation Sub #

If you prefer to keep the loop-based approach, update the Lokation sub to process all rows that have data in either column A or D (to ensure no rows are missed), and remove the redundant j variable:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Me.Range("A:A")) Is Nothing Then Exit Sub
    Application.EnableEvents = False
    On Error GoTo Finalize
    Call Lokation ' Make sure this calls your updated sub
Finalize:
    Application.EnableEvents = True
End Sub

Sub Lokation()
    Dim lastRow As Long, i As Long
    ' Get the last row with data in either column A or D
    lastRow = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row
    Dim dLastRow As Long
    dLastRow = Me.Cells(Me.Rows.Count, "D").End(xlUp).Row
    lastRow = IIf(lastRow > dLastRow, lastRow, dLastRow)
    
    For i = 2 To lastRow ' Assuming your data starts at row 2
        With Me.Cells(i, "D")
            If Trim(Me.Cells(i, "A").Value) = vbNullString Then
                .Value = vbNullString
            Else
                .Value = Mid(Me.Cells(i, "A").Value, 2, 3)
            End If
        End With
    Next i
End Sub

Key Improvements #

• Targeted Processing: Solution 1 only touches the rows that were actually modified, making it much more efficient.
• Full Row Coverage: Solution 2 ensures we process every row that has data in either column A or D, so no D column cells are left uncleared.
• Reduced Complexity: Removed the unnecessary j variable to make the code easier to read and maintain.

内容的提问来源于stack exchange，提问作者Markus Sacramento