Question

我有两列值，“A”只包含单词，每个单元格一个单词，列“B”包含网址，每个单元格一个网址。

以下代码确实在两列之间进行比较并且仅删除完全对应的值，即“A”在一个单元格中具有“erotic.com”值，而“B”在另一个单元格中具有“erotic.com”（然后值在“B”中删除，因为它匹配“A”的值

是否可以修改此代码以在“A”和“B”之间进行比较，如果“A”中的任何单词匹配，则删除“B”的值？例如“A”在一个单元格中有“色情”字样，而“B”在另一个单元格中有“erotic.com”字符（“B”中的值应该删除，“色情”在“A”中找到）？< / p>

Option Explicit
Function RangeFound(SearchRange As Range, _
Optional ByVal FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range

If StartingAfter Is Nothing Then
    Set StartingAfter = SearchRange(1)
End If

Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End Function
Sub ComparePermittedURLS()
Dim rngLastCell As Range
Dim rngColA As Range
Dim rngColB As Range
Dim n As Long, j As Long
Dim DIC As Object ' Scripting.Dictionary
Dim aryColB As Variant
Dim aryColA As Variant
Dim aryOutput As Variant
Dim startTime
Dim EndTime
startTime = Timer
'On Error GoTo ResetSpeed
'SpeedOn
Application.ScreenUpdating = False
With Sheets("permitted_urls") '<--Using worksheet's CodeName, or, using tab name--    >ThisWorkbook.Worksheets ("Sheet1")
     '// Find the last cell in each column, setting a reference to each column's range//
     '// that contains data.                                                         //
    Set rngLastCell = RangeFound(.Columns(1), , .Cells(1, 1))
    If Not rngLastCell Is Nothing Then Set rngColA = .Range(.Cells(1), rngLastCell)
    Set rngLastCell = RangeFound(.Columns(2), , .Cells(1, 2))
    If Not rngLastCell Is Nothing Then Set rngColB = .Range(.Cells(1, 2), rngLastCell)

     '// In case either column was empty, provide a bailout point.                   //
    If rngColA Is Nothing Or rngColB Is Nothing Then
        MsgBox "No data"
        Exit Sub
    End If

    Set DIC = CreateObject("Scripting.Dictionary")
    aryColA = rngColA.Value
     '// fill the keys with unique values from Column A  //
    For n = 1 To UBound(aryColA, 1)
        DIC.Item(CStr(aryColA(n, 1))) = Empty
    Next

    aryColB = rngColB.Value
     '// Size an output array to the current size of data in Column B, so we can just//
     '// overwrite the present values.                                               //
    ReDim aryOutput(1 To UBound(aryColB, 1), 1 To 1)

     '//  Loop through the current values, adding just the values we don't find in   //
     '// the dictionary to out output array.                                         //
    For n = 1 To UBound(aryColB)
        If Not DIC.Exists(CStr(aryColB(n, 1))) Then
            j = j + 1
            aryOutput(j, 1) = aryColB(n, 1)
        End If
    Next

     '// Kaplunk.    //
    rngColB.Value = aryOutput

    Set DIC = Nothing
    Erase aryColA
    Erase aryColB
    Erase aryOutput
End With
'ResetSpeed:
'SpeedOff
Application.ScreenUpdating = True
EndTime = Timer
MsgBox "Total Time: " & EndTime - startTime

End Sub

Answer 1

Sub ComparePermittedURLS()

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

    With Sheets("permitted_urls")
        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

比较Excel中的两列，并从第二列中删除匹配的第二列

1 个答案: