Question

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

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

问题：

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

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

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

＆＃34;你必须点击另一个小区＆＃34; ＆安培; vbNewLine＆amp; ＆＃34;然后点击返回＆＃34; ＆安培; Target.Address＆amp; ＆＃34;改变价值＆＃34;＆＃34;

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

问题＃3：我偶尔会遇到复制/粘贴问题。发生的事情（仅在某些情况下）会复制A，B，C，D，E，F列，然后将A列从主工作表粘贴到选择工作表中的A列，但是从主工作表到B列的C列在选择工作表中，列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宏（每种情况都有一个类似的宏）。这些在模块中：

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中，然后才能返回到它并从下拉列表中将值编辑到另一个。

首先，在Application.ScreenUpdating = False的{{1}}之后添加Set rng = ...。当您在下拉列表中添加值时，这将使屏幕停止闪烁。在Worksheet_Change正上方添加Application.ScreenUpdating = True，将其重置为标准。

高于End Sub添加Set rng = ...。我们将使用它来查找最后一行。然后转到Dim LastRow As Long之后的行并添加此行strFindF = Sheets(..。它将找到上一页的最后一行，我们将删除该值。
在此之后，将LastRow = Worksheets(cbxOldVal).Cells(Worksheets(cbxOldVal).Rows.Count, "A").End(xlUp).Row替换为：For Loop。

我希望您添加的最后一部分是，当您收到问题＃3错误时，您可以尝试自己调试代码。在最后For i = 1 To LastRow和新添加的End If之间添加此项。它现在可能是正确的，因为我无法复制您的错误。但是当你弄清楚如何触发错误时，你应该在代码中的某处插入一个断点（F9）。

Application.ScreenUpdating = False

Excel VBA - 如果更改了下拉列表中的选择，则复制数据工作表

1 个答案: