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

问题描述

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

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

问题：

当我从上一个问题测试答案时，工作正常。然而，现在有一些新问题，我没有数千行真实数据

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

问题＃2：发送消息框错误。当错误信息弹出并说，

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

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

问题＃3：我偶尔遇到了一个复制/粘贴问题。发生什么（仅有时）会将列A，B，C，D，E，F复制，然后将主工作表中的列A粘贴到选择工作表中的列A，从主工作表将B列C列到列B在选择工作表中，列D从主工作表到列C中的选择工作表，列E从主工作表到列D中的选择工作表和列F从主工作表到列E中的选择工作表我没有想法从主工作表中B列发生了什么（我的猜测是因为主工作表中的B列总是空白的，它决定不将其复制到新的工作表中）？

$ b $这是我的乐曲运行一次下拉值的nt代码被更改：

  Option Explicit 
 Public cbxOldVal As String 
 Dim PrevVal As Variant 
 
 Private Sub Worksheet_SelectionChange（ByVal Target As Range）
如果Target.Rows.Count> 1然后退出Sub 
如果Target.Columns.Count> 1然后退出Sub 
 
 cbxOldVal = Target.Value 
 End Sub 
 
 Private Sub Worksheet_Activate（）
如果Selection.Rows.Count = 1和选择.Columns.Count = 1然后
 PrevVal = Selection.Value 
 Else 
 PrevVal =选择
如果
 End Sub 
 
 
 Private Sub Worksheet_Change（ByVal Target As Range）
 Dim rng As Range，c As Range 
 Set rng = Intersect（Target，Range（G2：G30000））
 
如果不相交（目标，列（G））否则为
如果PrevVal<> 或cbxOldVal 然后
如果cbxOldVal = Target.Value然后
 MsgBox你必须点击另一个单元格& vbNewLine& 然后点击& Target.Address& 更改值，vbExclamation，错误
单元格（Target.Row，Target.Column）= PrevVal 
退出子
 ElseIf Target.Value =或Target.Value = PrevVal然后退出Sub 
 End If 
 End If 
 End If 
 
如果不是rng是没有，然后
对于每个c在rng.Cells 
选择案例c.Value 
案例权力：权力c 
案例气体：气体c 
案例水：水c 
案例杂货等 ：GroceriesEtc c 
案例Eat Out：EatOut c 
案例Amazon：Amazon c 
案例Home：首页c 
案例娱乐：娱乐c 
病例自动：自动c 
病例医疗：医疗c 
病例牙科：牙科c 
病例收入：收入c 
病例劳动 ：劳工c 
案例联盟会费：UnionDues c 
案例其他：其他c 
结束选择
 
如果cbxOldVal =然后
'不做任何
 
 Else 
 
与工作表（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 （大师）范围（A& c.Row）
 strFindB = Sheets（Master）。Range（B& c.Row）
 strFindC = Sheets（Master）。Range（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 
 
如果.Cells（i，1）.Value = strFindA _ 
 And .Cells（i，2）.Value = strFindB _ 
 And .Cells（i，3）.Value = strFindC _ 
和.Cells（i，4）.Value = strFindD _ 
 And .Cells（i，5）.Value = strFindE _ 
 And .Cells（i，6）.Value = strFindF _ 
然后
 
 .Rows（i）.EntireRow.Delete 
 MsgBoxDeleted Row& i 
 GoTo跳过
 
结束如果
 
下一步i 
 
结束
结束如果
跳过： 
 
下一步c 
如果
结束Sub 
  

这是从上面的代码中释放的大小写宏（每种情况都有类似的宏）。这些在模块中：

  Sub Power（c As Range）
 
 Dim rng As Range 
 
设置rng = Nothing 
设置rng =范围（A& c.Row&：F& c.Row）'< A1：F1这里是*相对于c.EntireRow * 
 
'复制值
与Worksheets（Power）。单元格（Rows.Count，1）.End（xlUp）
 .Offset（1，0）.Resize（1，rng.Cells.Count）.Value = rng.Value 
 
'从主表复制表单
使用工作表（Master ）
范围（A& c.Row&：F& c.Row）.Copy 
结束
 .Offset（1，0）.PasteSpecial xlPasteFormats 
 Application.CutCopyMode = False 
 
结束
 
 End Sub 
  

以下是电子表格的链接： 1drv.ms/x/s！ Amd7vhcV4dnOcJsB3KUiCLn6kPI 。

任何建议？

解决方案

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

记住，您必须移出目前的单元格，您在列G中添加了一个值，然后才能返回到该列，并从下拉列表中将值修改为另一个。

首先，添加 Application.ScreenUpdating = False 在 Worksheet_Change C>。当您在下拉列表中添加值时，这将停止屏幕闪烁。在 End Sub 之上添加 Application.ScreenUpdating = True 将其重新设置为标准。

以上设置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）代码中的某个地方，当你弄清楚如何触发错误。

 '调试问题＃3 
如果Target.Value =然后
'不做任何
 Else 
 LastRow = Worksheets（Target.Value）.Cells（Worksheets（Target.V ）（）（）（）（）（）（）（）（）（） ）.Cells（Target.Row，3）= Sheets（Target.Value）.Cells（LastRow，2）Then 
 MsgBoxError＃3
 End If 
 End If 
  

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

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.

Problem:

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

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.

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

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

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.

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

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

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

Any Suggestions?

解决方案

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?

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.

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.

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.

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

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