VBA宏來比較和增加值

Question

我想要做一個宏來比較一張紙上的值與另一張紙上的值並複製唯一的值。

說明：
我每週都會得到一堆ID（工作表A）。我想看看在過去的幾周裏，我已經使用了哪些這些ID（該列表位於Worksheet B上），並將Worksheet A中新的所有值複製到Worksheet B中。您可以將想要的結果看作Worksheet B（在運行宏之後）。

，我想出了一些代碼，但因爲我是新來的VBA，這是行不通的，我現在很絕望。感謝任何人的幫助。

Sub Mymacro() 
    Dim lastRowC As Long 
    Dim foundTrue As Boolean 
    Dim Data As Worksheet 
    Dim GivenValues As Worksheet 
    Dim IDs As Long 
    Dim fVal As Range 

    Set Data = Sheets("Worksheet B") 
    Set GivenValues = Sheets("Worksheet A") 
    lastRowC = Data.Cells(Rows.Count, 1).End(xlUp).Row 
    IDs = GivenValues.Cells(Rows.Count, 1).End(xlUp).Row 
    'imagine data in Worksheet B are in the first column 

    For i = 1 To IDs 
     Set fVal = Data.Range("A1:A" & lastRowC).Find(GivenValues.Cells(i, 1).Value, LookIn:=xlValues, LookAt:=xlWhole) 
     If fVal Is Nothing Then 
      GivenValues.Cells(i, 1).Copy 
      Sheets(Data).Select 
      Range("A1").Select 
      Selection.End(xlDown).Select 
      ActiveCell.Offset(1, 0).Select 
      Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
       :=False, Transpose:=False 
     Else: End If 
    Next i 
End Sub 

Answer 1

代碼會是這樣的。

Sub Mymacro() 

    Dim lastRowC As Long 
    Dim foundTrue As Boolean 
    Dim Data As Worksheet 
    Dim GivenValues As Worksheet 
    Dim IDs As Long 
    Dim fVal As Range 
    Dim rngDB As Range, vDB, rngT As Range 
    Dim vR(), n As Long 

     Set Data = Sheets("Worksheet B") 
     Set GivenValues = Sheets("Worksheet A") 

     lastRowC = Data.Cells(Rows.Count, 1).End(xlUp).Row 
     IDs = GivenValues.Cells(Rows.Count, 1).End(xlUp).Row 
     Set rngDB = Data.Range("a1", "a" & lastRowC) 

     With GivenValues 
      vDB = .Range("a1", "a" & IDs) 
     End With 
'imagine data in Worksheet B are in the first column 
      For i = 1 To IDs 
       Set fVal = rngDB.Find(vDB(i, 1), LookIn:=xlValues, LookAt:=xlWhole) 
        If fVal Is Nothing Then 
         n = n + 1 
         ReDim Preserve vR(1 To n) 
         vR(n) = vDB(i, 1) 
        End If 
      Next i 
      Set rngT = Data.Range("a" & Rows.Count).End(xlUp)(2) 
      If n > 0 Then 
       rngT.Resize(n) = WorksheetFunction.Transpose(vR) 
      End If 
    End Sub 

如果你想除了重複，請看下一個代碼。

Sub Mymacro() 

    Dim lastRowC As Long 
    Dim foundTrue As Boolean 
    Dim Data As Worksheet 
    Dim GivenValues As Worksheet 
    Dim IDs As Long 
    Dim fVal As Range 
    Dim rngDB As Range, vDB, rngT As Range 
    Dim vR(), n As Long 
    Dim X As New Collection 

     Set Data = Sheets("Worksheet B") 
     Set GivenValues = Sheets("Worksheet A") 

     lastRowC = Data.Cells(Rows.Count, 1).End(xlUp).Row 
     IDs = GivenValues.Cells(Rows.Count, 1).End(xlUp).Row 
     Set rngDB = Data.Range("a1", "a" & lastRowC) 

     With GivenValues 
      vDB = .Range("a1", "a" & IDs) 
     End With 
'imagine data in Worksheet B are in the first column 
     On Error Resume Next 
      For i = 1 To IDs 
       Set fVal = rngDB.Find(vDB(i, 1), LookIn:=xlValues, LookAt:=xlWhole) 
        If fVal Is Nothing Then 
         Err.Clear 
         X.Add vDB(i, 1), CStr(vDB(i, 1)) 
         If Err.Number = 0 Then 
          n = n + 1 
          ReDim Preserve vR(1 To n) 
          vR(n) = vDB(i, 1) 
         End If 
        End If 
      Next i 
      Set rngT = Data.Range("a" & Rows.Count).End(xlUp)(2) 
      If n > 0 Then 
       rngT.Resize(n) = WorksheetFunction.Transpose(vR) 
      End If 
End Sub