如果更改下拉列表中的选择，则将数据复制到工作表

Question

跟进之前回答的问题：Excel VBA - Delete Data from a Worksheet If Selection from Dropdown List is Changed

当前：这是一个个人费用电子表格，我正在使用我的主工作表上的 G 列对从我的信用合作社提供的 .csv 导入的行项目费用进行分类。 G 列中的每个单元格都有一个下拉列表，它是我的工作簿中其他工作表的名称：Power、Gas、Groceries 等。目前，当您从 G 列下拉列表中进行选择时，它会复制 A1:F1 的当前行并将其粘贴到所选工作表的下一个空行，例如电力或天然气或杂货。

问题：

当我测试上一个问题的答案时，它运行良好。但是，现在有一些新问题不是我有千行真实数据

问题 #1： 将行复制和粘贴到其他工作表仅适用于我从下拉列表中选择工作表的前几次。例如，在单元格 G2 中，我从下拉列表中选择“外出就餐”，它会将 A1:F1 复制到外出就餐工作表中。但是，如果我去 G11 并选择亚马逊，它不会做任何事情。它似乎适用于我尝试做的前 3 或 4 行，但不适用于其余的。当我说它不起作用时，它只是不会复制到任何工作表中。

问题 #2： 我遇到了一个永无止境的消息框错误。当错误消息弹出并说，

"你必须点击另一个单元格" & vbNewLine & "然后再点击" & Target.Address & "来改变值""

我点击确定，它只是再次弹出，不会让我做任何其他事情。它只是不断弹出，摆脱错误消息的唯一方法是强制退出 Excel。

问题 #3： 我偶尔会遇到复制/粘贴问题。发生的情况（仅有时）是它会复制 A、B、C、D、E、F 列，然后将主工作表中的 A 列粘贴到选择工作表中的 A 列，但将主工作表中的 C 列粘贴到 B 列在选择工作表中，主工作表中的 D 列到选择工作表中的 C 列，主工作表中的 E 列到选择工作表中的 D 列，以及主工作表中的 F 列到选择工作表中的 E 列。我不知道主工作表中的 B 列发生了什么（我的猜测是由于主工作表中的 B 列始终为空白，因此决定不将其复制到新工作表中？）？

这是我当前的代码，一旦更改下拉值就会运行：

Option Explicit
Public cbxOldVal As String
Dim PrevVal As Variant

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Rows.Count > 1 Then Exit Sub
If Target.Columns.Count > 1 Then Exit Sub

cbxOldVal = Target.Value
End Sub

Private Sub Worksheet_Activate()
    If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then
        PrevVal = Selection.Value
    Else
        PrevVal = Selection
    End If
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
Set rng = Intersect(Target, Range("G2:G30000"))

If Not Intersect(Target, Columns("G")) Is Nothing Then
    If PrevVal <> "" Or cbxOldVal <> "" Then
        If cbxOldVal = Target.Value Then
            MsgBox "You have to click on another cell " & vbNewLine & "and then click back on " & Target.Address & " to change the value", vbExclamation, "Error"
            Cells(Target.Row, Target.Column) = PrevVal
            Exit Sub
        ElseIf Target.Value = "" Or Target.Value = PrevVal Then Exit Sub
        End If
    End If
End If

If Not rng Is Nothing Then
    For Each c In rng.Cells
        Select Case c.Value
            Case "Power": Power c
            Case "Gas": Gas c
            Case "Water": Water c
            Case "Groceries, etc.": GroceriesEtc c
            Case "Eating Out": EatingOut c
            Case "Amazon": Amazon c
            Case "Home": Home c
            Case "Entertainment": Entertainment c
            Case "Auto": Auto c
            Case "Medical": Medical c
            Case "Dental": Dental c
            Case "Income": Income c
            Case "Labor": Labor c
            Case "Union Dues": UnionDues c
            Case "Other": Other c
        End Select

If cbxOldVal = "" Then
' do nothing

Else

    With Worksheets(cbxOldVal)

        Dim i As Integer
        Dim strFindA As String, strFindB As String, strFindC As String
        Dim strFindD As String, strFindE As String, strFindF As String
        strFindA = Sheets("Master").Range("A" & c.Row)
        strFindB = Sheets("Master").Range("B" & c.Row)
        strFindC = Sheets("Master").Range("C" & c.Row)
        strFindD = Sheets("Master").Range("D" & c.Row)
        strFindE = Sheets("Master").Range("E" & c.Row)
        strFindF = Sheets("Master").Range("F" & c.Row)

        For i = 1 To 100    ' replace with lastrow

        If .Cells(i, 1).Value = strFindA _
        And .Cells(i, 2).Value = strFindB _
        And .Cells(i, 3).Value = strFindC _
        And .Cells(i, 4).Value = strFindD _
        And .Cells(i, 5).Value = strFindE _
        And .Cells(i, 6).Value = strFindF _
        Then

        .Rows(i).EntireRow.Delete
        MsgBox "Deleted Row " & i
        GoTo skip:

        End If

        Next i

    End With
End If
skip:

    Next c
End If
End Sub

这是从上述代码中触发的 case 宏（每个 case 都有一个类似的宏）。这些在模块中：

Sub Power(c As Range)

Dim rng As Range

Set rng = Nothing
Set rng = Range("A" & c.Row & ":F" & c.Row) '<< A1:F1 here is *relative to c.EntireRow*

'copy the values
With Worksheets("Power").Cells(Rows.Count, 1).End(xlUp)
    .Offset(1, 0).Resize(1, rng.Cells.Count).Value = rng.Value

    ' Copy formating from Master Sheet
    With Worksheets("Master")
        Range("A" & c.Row & ":F" & c.Row).Copy
    End With
    .Offset(1, 0).PasteSpecial xlPasteFormats
    Application.CutCopyMode = False

End With

End Sub

这是电子表格的链接：1drv.ms/x/s!Amd7vhcV4dnOcJsB3KUiCLn6kPI。

有什么建议吗？

Answer 1

在我编辑 50 行后测试了代码，没有收到任何错误。所以希望它是固定的，或者它非常罕见。而且您似乎也无法复制错误？

记住，您必须先移出已在 G 列中添加值的当前单元格，然后才能移回该单元格并从下拉列表中将值编辑为另一个。

首先，在Worksheet_Change中的Set rng = ...后面加上Application.ScreenUpdating = False。当您在下拉列表中添加一个值时，这将停止屏幕闪烁。在End Sub 上方添加Application.ScreenUpdating = True 以将其重置为标准。

在Set rng = ... 上方添加Dim LastRow As Long。我们将使用它来查找最后一行。然后转到strFindF = Sheets(.. 之后的行并添加此行LastRow = Worksheets(cbxOldVal).Cells(Worksheets(cbxOldVal).Rows.Count, "A").End(xlUp).Row。它将找到上一张工作表的最后一行，我们正在删除其中的值。
在此之后，将您的 For Loop 替换为：For i = 1 To LastRow。

我希望您添加的最后一点是，当您收到问题 #3 错误时，您可以尝试自己调试代码。在最后一个 End If 和新添加的 Application.ScreenUpdating = False 之间添加这个。现在可能是正确的，因为我无法复制您的错误。但是，当您弄清楚如何触发错误后，您应该在代码中的某处插入一个断点 (F9)。

' Debug issue #3
If Target.Value = "" Then
' do nothing
Else
    LastRow = Worksheets(Target.Value).Cells(Worksheets(Target.Value).Rows.Count, "A").End(xlUp).Row
    Debug.Print Target.Row
    Debug.Print LastRow

    If Sheets("Master").Cells(Target.Row, 3) = Sheets(Target.Value).Cells(LastRow, 2) Then
        MsgBox "Error #3"
    End If
End If