Question

我需要帮助修改此代码以匹配2个工作表中的First和Last名称，然后从Sub工作表中删除匹配项。目前它只匹配1张纸上的2列。细节：

如何更改此代码，以便'工作表1'列'B'上的名称与'工作表2'列'E'和'上的名称匹配所有匹配都从'Sheet 1'中删除。对于'Sheet 1'列'C'到'Sheet 2'列'F'，重复相同。

Sub CompareNames()

Dim rngDel As Range
Dim rngFound As Range
Dim varWord As Variant
Dim strFirst As String

With Sheets("ADULT Sign On Sheet")
    For Each varWord In Application.Transpose(.Range("A1", .Cells(.Rows.Count,"A").End(xlUp)).Value)
        If Len(varWord) > 0 Then
            Set rngFound = .Columns("B").Find(varWord, .Cells(.Rows.Count, "B"), xlValues, xlPart)
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                Do
                    If Not rngDel Is Nothing Then Set rngDel = Union(rngDel, rngFound) Else Set rngDel = rngFound
                    Set rngFound = .Columns("B").Find(varWord, rngFound, xlValues, xlPart)
                Loop While rngFound.Address <> strFirst
            End If
        End If
    Next varWord
End With

If Not rngDel Is Nothing Then rngDel.Delete

Set rngDel = Nothing
Set rngFound = Nothing

End Sub

Answer 1

循环播放Sheet1列B中的所有值。如果在Sheet2列E中找到该值，则会删除Sheet1中的整个行。然后循环遍历Sheet1 C列中的所有值。如果在Sheet2列F中找到该值，则删除Sheet1中的整行。

Sub DeleteCopy()

Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long

LastRow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
DestLast = Sheets("Sheet2").Range("E" & Rows.Count).End(xlUp).Row

For CurRow = 2 To LastRow 'Assumes your first row of data is in row 2
    If Not Sheets("Sheet2").Range("E2:E" & DestLast).Find(Sheets("Sheet1").Range("B" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
        Sheets("Sheet1").Range("B" & CurRow).Value = ""
    Else
    End If
Next CurRow

LastRow = Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
DestLast = Sheets("Sheet2").Range("F" & Rows.Count).End(xlUp).Row

For CurRow = 2 To LastRow 'Assumes your first row of data is in row 2
    If Not Sheets("Sheet2").Range("F2:F" & DestLast).Find(Sheets("Sheet1").Range("C" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
        Sheets("Sheet1").Range("C" & CurRow).Value = ""
    Else
    End If
Next CurRow

End Sub

Answer 2

试试这个，你必须用第一个标准再调用一次，然后再用第二个标准调用它

我认为我已根据第一个标准正确设置

Sub DeleteIfMatchFound()
Dim SearchValues As Variant
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim sLR As Long, tLR As Long, i As Long

Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Set wsTarget = ThisWorkbook.Worksheets("Sheet2")

          sLR = wsSource.Range("B" & wsSource.Rows.Count).End(xlUp).Row
          tLR = wsTarget.Range("E" & wsSource.Rows.Count).End(xlUp).Row
   SearchValues = wsSource.Range("B2:B" & sLR).Value

     For i = 1 To (tLR - 1)
            If Not IsError(Application.match(SearchValues(i, 1), wsTarget.Range("E2:E" & tLR), 0)) Then
                wsTarget.Rows(i + 1).Delete
            End If
    Next i
End Sub

VBA首先删除匹配＆amp;两个工作表中的姓氏

2 个答案: