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宏（每种情况都有一个类似的宏）：

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:

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

1 个答案: