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