如果从下拉列表中选择更改了将数据复制到工作表 [英] Copy Data a Worksheet If Selection from Dropdown List is Changed

问题描述

将问题跟到先前回答的问题： Excel VBA-如果更改了下拉列表中的选择，则从工作表中删除数据

Follow up question to a previously answered question: Excel VBA - Delete Data from a Worksheet If Selection from Dropdown List is Changed

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

Current: This is for a personal expense spreadsheet and I am using Column G on my Master worksheet to classify line item expenses imported from a .csv provided by my credit union. Each cell in Column G has a dropdown list which is the name of the other worksheets in my workbook: Power, Gas, Groceries, etc. Currently, when you make a selection from the Column G dropdown list, it copies A1:F1 of the current row and pastes it to the next empty row of whatever worksheet was selected, e.g. Power or Gas or Groceries.

问题：

虽然我正在测试上一个问题的答案，但效果很好。但是，现在出现了一些新问题，不是我有数千行真实数据

While I was testing the answer from my previous question, it worked fine. However, there are now some new issues not that I have thousand of rows of real data

问题＃1：行的复制和粘贴其他工作表只能在前几次工作，我从下拉列表中选择了一个工作表。例如，在单元格G2中，我从下拉列表中选择就餐，它将A1：F1复制到就餐工作表中。但是，如果我转到G11并选择亚马逊，它将无济于事。它似乎可以在我尝试执行的前3或4行中起作用，但对其余行却不起作用。当我说这行不通时，它只是不会复制到任何工作表。

Issue #1: The copy and pasting of rows to other worksheets only works for the first few times I select a worksheet from the dropdown. For example, in cell G2, I select "Eating Out" from the dropdown, it will copy A1:F1 to the eating out worksheet. However, if if I go to G11 and select Amazon it won't do anything. It seems to work on the first 3 or 4 rows that I try to do but doesn't work on the rest. When I say it won't work, it just doesn't copy to any worksheet.

问题2：我遇到了一个从不结束消息框错误。当错误消息弹出并显示时，

Issue #2: I ran into a never-ending message box error. When the error message pops-up and says,

您必须单击另一个单元格& vbNewLine& ，然后再次点击&目标地址和地址更改值。

"You have to click on another cell " & vbNewLine & "and then click back on " & Target.Address & " to change the value""

我单击确定，它再次弹出，不允许我执行任何其他操作。它一直在弹出，并且是唯一的消除错误消息的方法是强制退出Excel。

I click OK, and it just pops up again and won't let me do anything else. It just keeps popping up and the only way to get rid of the error message is to Force Quit Excel.

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

Issue #3: I sporadically ran into an copy/paste issue. What happens (only sometimes) is that it would copy column A,B,C,D,E,F and then paste column A from the master worksheet to column A in the selection worksheet, BUT column C from the master worksheet to column B in the selection worksheet, column D from the master worksheet to column C in the selection worksheet, column E from the master worksheet to column D in the selection worksheet and column F from the master worksheet to column E in the selection worksheet. I have no idea what happened to Column B from the master worksheet (my guess is since Column B from the master worksheet is always blank, it decided not to copy it over to the new worksheet?)?

这是我当前的下拉值更改后运行的代码：

Here is my current code that runs once a dropdown value is changed:

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宏（每种情况都有一个类似的宏）。这些在模块中：

Here is the case macro that is fired off from the above code (there is a similar macro for each case). These are in the Module:

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！

Here is a link to the spreadsheet: 1drv.ms/x/s!Amd7vhcV4dnOcJsB3KUiCLn6kPI.

有什么建议吗？

推荐答案

已测试我在50行中编辑后的代码未收到任何错误。因此，希望它是固定的，或者非常罕见。看来您也无法复制错误？

Tested the code after I edited on 50 rows, didn't receive any errors. So hopefully it is fixed, or it is very uncommon. And it seems like you are not able to replicate the errors as well?

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

Remember that you have to move out of the current cell that you have added a value to in Column G, before you can move back into it and edit the value to another from the dropdown list.

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

First of all, add Application.ScreenUpdating = False after the Set rng = ... in the Worksheet_Change. This will stop the screen to shimmer, when you add a value in the dropdown list. Add Application.ScreenUpdating = True just above the End Sub to reset it to standard.

在上方设置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 。

Above Set rng = ... add Dim LastRow As Long. We will use this to find the last row. Afterwards go to the line after strFindF = Sheets(.. and add this line LastRow = Worksheets(cbxOldVal).Cells(Worksheets(cbxOldVal).Rows.Count, "A").End(xlUp).Row. It will find the last row of the previous sheet, where we are deleting the value for.
After this, replace your For Loop with this: For i = 1 To LastRow.

我最后要添加的部分是，这样您就可以在遇到问题＃3错误时尝试自己调试代码。请在最后一个 End If 之间添加此代码。 code>和新添加的 Application.ScreenUpdating = False 。现在可能是正确的，因为我无法复制您的错误，但是您应该插入一个点（F9）在代码中的某个地方，当您知道如何触发错误时。

The last piece that I want you to add, is so you can try to debug the code yourself when your receive your issue #3 error. Add this between the last End If and the newly added Application.ScreenUpdating = False. It might now be correct, since I am not able to replicate your error. But you should insert a breaking point (F9) somewhere in the code, when you have figured out how to trigger the error.

' 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

这篇关于如果从下拉列表中选择更改了将数据复制到工作表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！