无法让 VBA 代码工作，该代码允许根据从下拉列表中选择的数据将数据从一个工作表复制到另一个工作表

Question

如何根据下拉列表中所选的项目将整行复制到另一个工作表。如果选择包含下拉列表的单元格 E2 中的选项 1，我想将该行复制到工作表 2，如果选择包含下拉列表的单元格 E2 中的选项 2，我想将该行复制到工作表 3，如果选择选择包含下拉列表的单元格 E2 我想将该行复制到工作表 4 等

选项 1 将处于“活动”状态，该选项可作为下拉菜单丢失的选项找到，该选项可在名为“单元格 A1 中的数据验证”的选项卡 2 中找到

选项 2 将悬而未决，它是作为下拉列表丢失的选项找到的，该选项位于单元格 A4 中名为“数据验证”的选项卡 2 上

选项 3 将被更新，它是作为下拉菜单丢失的选项找到的，该选项位于单元格 A5 中称为“数据验证”的选项卡 2 上

现在 tab1 Called All 如果单元格 E2 更改为“活动”，那么我希望将整行复制到称为“活动”的选项卡 3，就好像下一个单元格 E3 从下拉列表中更改为“待处理”，那么整行将被复制到名为“待定”的选项卡 4，如果更改为“已更新”，它将被复制到名为“已更新”的选项卡 5。

我尝试了以下VBA代码，但它不起作用

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim KeyCell As Range
    Set KeyCell = Range("E2")

    If Not Application.Intersect(KeyCell, Range(Target.Address)) _
        Is Nothing Then

        Select Case KeyCell.Value
            Case "Active"
                Call CopyRow(Target.Row, "Sheet3")
            Case "Pending"
                Call CopyRow(Target.Row, "Sheet4")
            Case "Renewed"
                Call CopyRow(Target.Row, "Sheet5")

            ' Add more cases as needed

        End Select
    End If

End Sub

Sub CopyRow(rowNumber As Integer, sheetName As String)
    Dim lastRow As Long
    lastRow = Sheets(sheetName).Cells(Rows.Count, 1).End(xlUp).Row + 1
    Rows(rowNumber & ":" & rowNumber).Copy Destination:=Sheets(sheetName).Rows(lastRow)
End Sub

一旦我从下拉列表中选择了某些内容，它就无法将数据复制到相关工作表。

Answer 1

工作表更改：复制到下拉列表指定的工作表

主要

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim keyCell As Range: Set keyCell = Me.Range("E2")

    If Intersect(keyCell, Target) Is Nothing Then Exit Sub
    
    Dim rrg As Range: Set rrg = keyCell.EntireRow
    
    Dim dSheetName As String
    
    Select Case LCase(CStr(keyCell.Value))
        Case "active": dSheetName = "Sheet3"
        Case "pending": dSheetName = "Sheet4"
        Case "renewed": dSheetName = "Sheet5"
        ' Add more cases as needed
        'Case Else ' neither; do nothing?
    End Select
    
    If Len(dSheetName) > 0 Then CopyEntireRow rrg, dSheetName

End Sub

帮助

Sub CopyEntireRow(sourceEntireRow As Range, DestinationSheetName As String)
    
    Dim sws As Worksheet: Set sws = sourceEntireRow.Worksheet
    Dim wb As Workbook: Set wb = sws.Parent
        
    Dim dws As Worksheet, dcell As Range
    
    On Error Resume Next
        Set dws = wb.Worksheets(DestinationSheetName)
    On Error GoTo 0
    
    If dws Is Nothing Then
        MsgBox "No worksheet named """ & DestinationSheetName _
            & """ in workbook """ & wb.Name & """ located at """ & wb.Path _
            & """!", vbExclamation
        Exit Sub
    End If
    
    If dws Is sws Then
        MsgBox "Cannot modify (source) worksheet """ & sws.Name & """!", _
            vbExclamation
        Exit Sub
    End If
    
    With dws.UsedRange
        With .Cells(1).Offset(.Rows.Count - 1)
            If .Row = dws.Rows.Count Then
                MsgBox "The worksheet """ & dws.Name & """ is full!", _
                    vbExclamation
                Exit Sub
            End If
            Set dcell = .Offset(1).EntireRow.Columns("A")
        End With
    End With
    
    sourceEntireRow.Copy Destination:=dcell

End Sub