如果下拉列表中的选择发生更改，则从工作表中删除数据

Question

跟进之前回答的问题：Excel VBA - Run a macro based on a range of dropdown lists。

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

问题：但是，如果我重新分类线路费用，例如从我最初的选择Gas 中，我将其更改为Power，它将再次复制当前行的A1:F1 并移动到Power 工作表。这很好，但我需要它来删除我们从Gas 选项卡中复制的行。

可能的解决方案？：我能想到的唯一方法是添加类似这样的内容...如果下拉列表不是空白并且我更改了原始选择，那么我需要找到A1:F1 的精确文本副本（A1 ：日期，B1：编号，C1：描述，D1：借方，E1：贷方，F1：注释 - 这些将（“应该”）永远不会重复）从原始选择工作表（Gas）并删除这些单元格和向上移动下面的行。我正在寻求帮助，请有人用代码编写上述场景并向我展示它在我当前代码中的样子（我在新手级别上了解 VBA - 充其量）。

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

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
Set rng = Intersect(Target, Range("G2:G1001"))
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 "Other": Other c
        End Select
    Next c
End If
End Sub

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

Sub Gas(c As Range)

Dim rng As Range

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

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

End Sub

有什么建议吗？

Answer 1

试试这个。你可能需要稍微调整一下，但它应该能让你继续前进。我添加了一个全局变量，您可以存储下拉列表中的前一个值。
在SelectionChange 中，我尝试创建一个错误处理来处理选定的多个单元格。如果只选择了 1 个单元格，则该值将绑定到全局变量。然后你可以使用该变量在下拉列表中找到上一个值的工作表，循环访问工作表并删除该值。

首先，我已将此添加到您的 Gas、Power 等潜艇中。使它们充满活力。

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

在主表（不是模块）下，我添加了这个：

' Add this to the absolute top of the sheet, must be outside a procedure (sub)
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

将此添加到您的 Worksheet_Change 事件中。

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

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
' Your loop

然后我在您的Worksheet_Change 事件中添加了一些代码。将此添加到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: