Question

我想做一个宏来比较一张纸上的值和另一张纸并复制唯一值。

说明：
我每周都会得到一堆身份证（工作表A）。我想看看我在前几周已经使用过哪些ID（该列表在工作表B上），并将工作表A中的所有值（即新的）复制到工作表B.您可以将所需结果看作工作表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

VBA宏来比较和增加价值

1 个答案: