1

セルごとに 1 つの単語を含む単語のみを含む「A」と、セルごとに 1 つの URL を含む URL を含む列「B」の 2 つの値の列があります。

次のコードは、両方の列を比較し、正確に対応する値のみを削除します。つまり、「A」のセルには「erotic.com」の値があり、「B」には別のセルに「erotic.com」の値があります (次に「B」の値" は "A" の値と一致するため削除されます)

このコードを変更して、「A」と「B」を比較し、「A」のいずれかの単語が一致する場合は「B」の値を削除できますか? たとえば、「A」のあるセルに「erotic」という単語があり、「B」の別のセルに「erotic.com」という URL があります (「A」に「erotic」があるため、「B」の値を削除する必要があります)。

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
4

1 に答える 1

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
于 2013-08-23T17:48:17.957 に答える