请求修改VBA代码：仅复制A:L列至对应工作表而非整行

Got it, let's tweak your code so it only copies columns A:L instead of the whole row, plus clean up some redundant logic to make it run smoother and avoid unexpected issues.

Key Changes Made: #

• Replaced EntireRow.Copy with a specific range reference to columns A:L of the target row
• Added Application.EnableEvents = False to prevent the macro from triggering itself when pasting (since pasting counts as a worksheet change)
• Removed redundant calls to LastRow and ScreenUpdating to optimize performance
• Fixed the RemoveDuplicates reference to target the correct worksheet instead of relying on ActiveSheet
• Added case-insensitive checking for "Yes" to handle different input capitalizations

Modified Code: #

Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range
    Set KeyCells = Me.Range("K:L") ' Use Me to refer directly to the current worksheet
    
    ' Check if the changed cell is in columns K or L
    If Not Application.Intersect(KeyCells, Target) Is Nothing Then
        Application.ScreenUpdating = False
        Application.EnableEvents = False ' Stop macro from triggering itself during paste
        
        Dim LastRow As Long
        LastRow = Me.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        
        ' Handle entries for ASD 5P (Column K = Yes)
        Dim x5P As Long
        x5P = 3 ' Start pasting at row 3 in the target sheet (adjust if your header is different)
        Dim rng As Range
        For Each rng In Me.Range("K3:K" & LastRow)
            If UCase(rng.Value) = "YES" Then ' Ignore capitalization differences
                ' Copy only columns A:L from the current row
                Me.Range("A" & rng.Row & ":L" & rng.Row).Copy _
                    Destination:=Sheets("ASD 5P").Cells(x5P, 1)
                x5P = x5P + 1
            End If
        Next rng
        ' Remove duplicates from ASD 5P sheet (only the rows we just added)
        Sheets("ASD 5P").Range("A3:L" & x5P - 1).RemoveDuplicates _
            Columns:=Array(4, 5, 6), Header:=xlNo
        
        ' Handle entries for ASD PD (Column L = Yes)
        Dim xPD As Long
        xPD = 3
        For Each rng In Me.Range("L3:L" & LastRow)
            If UCase(rng.Value) = "YES" Then
                Me.Range("A" & rng.Row & ":L" & rng.Row).Copy _
                    Destination:=Sheets("ASD PD").Cells(xPD, 1)
                xPD = xPD + 1
            End If
        Next rng
        ' Remove duplicates from ASD PD sheet
        Sheets("ASD PD").Range("A3:L" & xPD - 1).RemoveDuplicates _
            Columns:=Array(4, 5, 6), Header:=xlNo
        
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End If
End Sub

What Each Fix Does: #

1. Specific Range Copy: Me.Range("A" & rng.Row & ":L" & rng.Row).Copy targets exactly columns A to L of the row where "Yes" was entered, no extra columns included.
2. Event Disabling: Application.EnableEvents = False stops the macro from running again when we paste data into the target sheets (pasting triggers a worksheet change event). We re-enable it at the end to keep normal Excel functionality working.
3. Case-Insensitive Check: UCase(rng.Value) = "YES" ensures the macro works even if someone types "yes" or "Yes" instead of all caps.
4. Accurate Duplicate Removal: Instead of using ActiveSheet, we directly reference the target sheets (Sheets("ASD 5P") and Sheets("ASD PD")) to avoid errors if the active sheet isn't the one we want.

Quick Notes: #

• Double-check that sheet names "ASD 5P" and "ASD PD" match exactly what's in your workbook (sheet names are case-sensitive in some Excel versions).
• If your target sheets have a different starting row (not row 3), adjust the x5P = 3 and xPD = 3 values to match your header setup.
• The duplicate removal uses columns 4,5,6 (D,E,F) as unique identifiers—modify Columns:=Array(4,5,6) if you need to use different columns for checking duplicates.

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