Excel的VBA - 檢查重複項，然後從第1頁複製到第2頁的列值

Question

我試圖實現與Excel的「易」的任務是：

1. 讓用戶輸入一個數值插入列D（從第3行開始）SheetA。
2. 我希望Excel能夠仔細檢查條目是否在列D中重複。如果是，則應該觸發警告消息並取消條目。
3. 如果條目不是重複的，則應將新值複製到同一行中，但列A的SheetB。

這是我使用的代碼：

Private Sub Worksheet_Change(ByVal Target As Range) 

    Dim rng As Range, r As Range, msg As String, x As Range 
    Set rng = Intersect(Columns(4), Target) 'Column to check duplicate 

    If Not rng Is Nothing Then 

     Application.EnableEvents = False 
     For Each r In rng 
      If Not IsEmpty(r.Value) Then 
       If Application.CountIf(Columns(4), r.Value) > 1 Then 'Column to check duplicate...the last number remains 1 
        msg = msg & vbLf & vbTab 
        If x Is Nothing Then 
         r.Activate 
         Set x = r 
        Else 
         Set x = Union(x, r) 
        End If 
       End If 
      End If 
     Next 
     If Len(msg) Then 
      MsgBox "You have entered a duplicate EID" & msg 
      x.ClearContents 
      x.Select 
     End If 

     Set rng = Nothing 
     Set x = Nothing 
     Sheets("BSheet").Range("A3:A1048576").ClearContents 
     ASheet.Select 

     Dim EID As String 'define the column heading as a variable 
     Dim lastrow As Long 'define the last row 

     lastrow = ASheet.Cells(Rows.Count, 4).End(xlUp).Row 'this will give us the column number in ASheet 

     For i = 3 To lastrow 'here you say that 3rd row is going to be the 1st row to copy 
      EID = ASheet.Cells(i, 4) 'here you say that 4th column is going to be the column to copy 
      BSheet.Activate 
      erow = BSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 'this stay at 1 
      BSheet.Cells(erow, 1) = EID 'this stays at 1 
      ASheet.Activate 
     Next i 

     Application.EnableEvents = True 

    End If 

End Sub 

謝謝你提前爲這一個你的幫助。

Answer 1

用於複製控制使用高於其更有效率，那麼你可以用宏進行復制所需要的範圍內。

希望爲你