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

Question

后续问题之前回答的问题：Excel VBA - Delete Data from a Worksheet If Selection from Dropdown List is Changed

电流：这是一个个人的费用电子表格，我使用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，BUT将主工作表中的列C粘贴到选择工作表中的列B，将主工作表中的列D粘贴到选择工作表，从主工作表中的列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 

这里是从上面的代码发射了的情况下的宏（存在用于每一种情况下的类似宏）。这些在模块中：

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中添加了一个值，然后才能将其移回并从下拉列表中编辑值。

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

以上Set 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），当你已经知道如何触发错误时。

' 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