基于ITEMNO复制行至其他工作表失败：仅ITEMNO被复制，求VBA修复

Hey there, let's fix your VBA code so it copies the full set of columns you need instead of shoving everything into a single cell. The core issue is how you're assigning array values to Sheet2 — right now you're dumping the array into one cell, not spreading it across multiple columns. Here's the revised code with clear explanations:

Key Fixes Made #

• Expanded array assignment: Used .Resize() to spread your array values across the correct number of columns in Sheet2.
• Added error handling: Prevents runtime errors if the selected value isn't found in Table1.
• Robust row targeting: Fixed fragile hardcoded row offsets to work reliably with Excel tables.
• Event safety: Temporarily disabled events to avoid unintended recursive triggers.

Revised Full Code #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim x As Variant, i As Variant, lRow As Long
    ' Only run if the change is on the SerialNumber dropdown
    If Not Intersect(Target, [SerialNumber]) Is Nothing Then
        ' Disable events to prevent recursive triggers
        Application.EnableEvents = False
        
        ' Find the matching row in Table1 (handle cases where match isn't found)
        On Error Resume Next
        i = Application.Match(Target.Value, [Table1[ITEMNO]], 0)
        On Error GoTo 0
        
        If Not IsError(i) Then
            ' Get the full row range from Table1
            x = ActiveSheet.ListObjects(1).ListRows(i).Range
            
            ' Calculate next empty row in Sheet2
            lRow = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Row
            lRow = IIf(lRow < 2, 2, lRow + 1)
            
            ' Copy your desired columns (1,2,5,6,8) to Sheet2, spread across columns A-E
            Sheet2.Cells(lRow, 1).Resize(, 5).Value = Array(x(1, 1), x(1, 2), x(1, 5), x(1, 6), x(1, 8))
        End If
        
        ' Re-enable events
        Application.EnableEvents = True
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim x As Variant, lRow As Long, listRowIndex As Long
    ' Only run if selecting a single ITEMNO cell in Table1
    If Not Intersect(Target, [Table1[ITEMNO]]) Is Nothing And Target.Cells.Count = 1 Then
        Application.EnableEvents = False
        
        ' Get the correct ListRow index (no hardcoded offsets!)
        listRowIndex = Target.Row - Target.ListObject.HeaderRowRange.Row
        x = Target.ListObject.ListRows(listRowIndex).Range
        
        ' Calculate next empty row in Sheet2
        lRow = Sheet2.Cells(Sheet2.Rows.Count, 1).End(xlUp).Row
        lRow = IIf(lRow < 2, 2, lRow + 1)
        
        ' Copy 8 columns starting from ITEMNO to Sheet2, spread across columns A-H
        Sheet2.Cells(lRow, 1).Resize(, 8).Value = Array( _
            x(1, 1), x(1, 2), x(1, 3), x(1, 4), x(1, 5), x(1, 6), x(1, 7), x(1, 8) _
        )
        
        Application.EnableEvents = True
    End If
End Sub

Breakdown of Changes #

1. Worksheet_Change Event:

   • Added error handling for Application.Match so if the selected SerialNumber doesn't exist in Table1, the code won't crash.
   • Replaced .Cells(lRow, 1) = Array(...) with .Cells(lRow, 1).Resize(, 5) = Array(...) to spread the 5 values across columns A-E in Sheet2.
   • Simplified the next-row calculation with a cleaner IIf statement.

2. Worksheet_SelectionChange Event:

   • Removed the fragile Target.Row - 2 offset and replaced it with a dynamic way to get the ListRow index based on the table's header row.
   • Updated the array assignment to use .Resize(, 8) to spread your 8 columns across A-H in Sheet2.
   • Added a check Target.Cells.Count = 1 to avoid running if multiple cells are selected.

Now when you select from the SerialNumber dropdown or click an ITEMNO in Table1, the full set of columns you specified will be added to the end of Sheet2's table instead of just the first cell!

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