VBA to filter IP addresses based on first 2 octets

[addistexan]

Hello,
I've been trying to figure out how easily filter out IP addresses based on their first 2 octets. By using this platform and tweeking a formula, I was able to filter out IP addresses with an exact match. However, there are so many IP addresses in each range that I think it makes more sense to filter based on the first 2 octets instead. My original formula that works for match on full IP address is: =LET(x,FILTERXML("<x><y>"&SUBSTITUTE(A5,", ","</y><y>")&"</y></x>","//y"),TEXTJOIN(" ",1,FILTER(x,ISERROR(MATCH(x,FILTERXML("<x><y>"&SUBSTITUTE(TEXTJOIN(" ",1,CloudflareIP)," ","</y><y>")&"</y> </x>","//y"),0)),"")))

To make it more complicated, some cells have 1 IP address, and some may have up to 200 IP addresses in a single cell, all seperated by commas.

Now I've been trying to use a macro to look at each cell in my range (A1:A3000) in worksheet1, take each IP address, read the first 2 octets (e.g., 123.123.) and compare that to my list in worksheet2. I there is a match, I want the entire IP address from worksheet1 deleted, otherwise, go to the next. By the end, I want each cell to contain all the IP addresses is started with (with the matched ones removed), and all separated by a comma. Here are a couple of my attempts:

Sub FilterIPAddress1()

Dim Cell As Range
Dim cell2 As Range
Dim SearchRange As Range
Dim IPAddress As String
Dim OctetsSearchRange As Range
Dim OctetsToMatch As String


' OctetsToMatch = "" ' Replace with your desired first 2 octets

' Define the range to search for IP addresses (change this to match your actual range)
Set SearchRange = Worksheets("Sheet1").Range("A1:A3000")

'Define the range where Octets to search will be kept
Set OctetsSearchRange = Worksheets("Sheet2").Range("A1:D5000")

' Loop through each cell in worksheet 1
For Each Cell In SearchRange
If Cell.Value <> "" Then
' Extract the IP address in the first 2 octets
IPAddress = Left(Cell.Value, InStr(Cell.Value, ".") - 1)
' Loop through each Octet in worksheet 2
For Each cell2 In OctetsSearchRange
' Check if the Octet in Worksheet 1 matches an Octet in Worksheet 2
If IPAddress = OctetsToMatch Then
' If it matches, delete the entire IP address
Cell.ClearContents
End If
End If
Next Cell

End Sub
And another:
Sub FilterIPAddresses2()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim cell1 As Range
Dim cell2 As Range
Dim sentence As String
Dim ipParts() As String
Dim ipPart As Variant
Dim firstTwoOctets As String
Dim opticsToDelete As String

' Set the worksheets you want to work with
Set ws1 = ThisWorkbook.Worksheets("Sheet1") ' Change "Sheet1" to your first worksheet name
Set ws2 = ThisWorkbook.Worksheets("Sheet2") ' Change "Sheet2" to your second worksheet name

' Loop through each cell in the first worksheet
For Each cell1 In ws1.UsedRange
sentence = cell1.Value
opticsToDelete = ""

' Split the sentence into individual IP addresses based on commas
ipParts = Split(sentence, ",")

' Loop through each IP address
For Each ipPart In ipParts
' Extract the first two octets
firstTwoOctets = Left(ipPart, InStr(ipPart, ".", InStr(ipPart, ".") + 1) - 1)

' Check if the firstTwoOctets exist in the second worksheet
If WorksheetFunction.CountIf(ws2.UsedRange, firstTwoOctets) > 0 Then
' If it exists, add the entire IP address to the list to delete
opticsToDelete = opticsToDelete & ipPart & ","
End If
Next ipPart

Of course I'm not getting proper reults or errors and I am way beyond my ability. Thank you for any suggestions or assistance!

 

[Legacy 143009]

By stealing @Georgiboy 's TextJoin idea
I told that, string manipulation is not my strongest part.

Sub test()
Dim ipList As Object, ipListArr As Variant, lRow As Long, listItem As Variant, myData As Variant, tmp As Variant, j As Long, octes As String
  Set ipList = CreateObject("Scripting.Dictionary")
  With Worksheets("Sheet2")
  lRow = .Cells(Rows.Count, "A").End(xlUp).Row
  ipListArr = .Range("A1:A" & lRow)
  End With
  For Each listItem In ipListArr
    If Not ipList.Exists(Trim(listItem)) Then
      ipList.Add Trim(listItem), 1
    End If
  Next

  With Worksheets("Sheet1")
  lRow = .Cells(Rows.Count, "A").End(xlUp).Row
  myData = .Range("A1:A" & lRow)
  For i = 1 To UBound(myData, 1)
    tmp = Split(myData(i, 1), ",")
    For j = 0 To UBound(tmp)
      octes = Split(Trim(tmp(j)), ".")(0) & "." & Split(Trim(tmp(j)), ".")(1)
      If ipList.Exists(octes) Then
        tmp(j) = ""
      End If
    Next
    myData(i, 1) = Application.TextJoin(",", True, tmp)
  Next
  .Range("A1").Resize(UBound(myData, 1)).Value = myData
  End With
End Sub

 

[addistexan]

By stealing @Georgiboy 's TextJoin idea
I told that, string manipulation is not my strongest part.

Sub test()
Dim ipList As Object, ipListArr As Variant, lRow As Long, listItem As Variant, myData As Variant, tmp As Variant, j As Long, octes As String
  Set ipList = CreateObject("Scripting.Dictionary")
  With Worksheets("Sheet2")
  lRow = .Cells(Rows.Count, "A").End(xlUp).Row
  ipListArr = .Range("A1:A" & lRow)
  End With
  For Each listItem In ipListArr
    If Not ipList.Exists(Trim(listItem)) Then
      ipList.Add Trim(listItem), 1
    End If
  Next

  With Worksheets("Sheet1")
  lRow = .Cells(Rows.Count, "A").End(xlUp).Row
  myData = .Range("A1:A" & lRow)
  For i = 1 To UBound(myData, 1)
    tmp = Split(myData(i, 1), ",")
    For j = 0 To UBound(tmp)
      octes = Split(Trim(tmp(j)), ".")(0) & "." & Split(Trim(tmp(j)), ".")(1)
      If ipList.Exists(octes) Then
        tmp(j) = ""
      End If
    Next
    myData(i, 1) = Application.TextJoin(",", True, tmp)
  Next
  .Range("A1").Resize(UBound(myData, 1)).Value = myData
  End With
End Sub
[/CODE
[/QUOTE]
[USER=105714]@Georgiboy[/USER], [USER=143009]@Flashbond[/USER] - truly amazing. Thanks for help!!

 

[addistexan]

Hi again. This worked great with just IPv4 addresses in the cells, but today I ran into cells with IPv6. Of course this threw a wrench in the code success. Do you have any thoughts about how to skip over or remove IPv6 addresses in a cell? Everything is separated by commas.

 

[Legacy 143009]

What is the pattern of a IPv6 address? What is the difference?

 

[addistexan]

What is the pattern of a IPv6 address? What is the difference?

I think it change but for now I’m only seeing long pattern such as 2001:db8:85a3::8a2e:370:7334: The difference is an extra section and divided by “:” rather than “.”

 

[Legacy 143009]

I added a small cheat. Can you try this one:

Sub test()
Dim ipList As Object, ipListArr As Variant, lRow As Long, listItem As Variant, myData As Variant, tmp As Variant, j As Long, octes As String
  Set ipList = CreateObject("Scripting.Dictionary")
  With Worksheets("Sheet2")
  lRow = .Cells(Rows.Count, "A").End(xlUp).Row
  ipListArr = .Range("A1:A" & lRow)
  End With
  For Each listItem In ipListArr
    If Not ipList.Exists(Trim(listItem)) Then
      ipList.Add Trim(listItem), 1
    End If
  Next

  With Worksheets("Sheet1")
  lRow = .Cells(Rows.Count, "A").End(xlUp).Row
  myData = .Range("A1:A" & lRow)
  For i = 1 To UBound(myData, 1)
    tmp = Split(myData(i, 1), ",")
    For j = 0 To UBound(tmp)
      octes = Split(Trim(tmp(j)), ".")(0) & "." & Split(Trim(tmp(j)), ".")(1)
      If ipList.Exists(octes) Or Instr(tmp(j), ":") >0 Then 'I added a small condition here. If IP address includes semicolon, then remove. I think none of IPv4 addresses include a semicolon.
        tmp(j) = ""
      End If
    Next
    myData(i, 1) = Application.TextJoin(",", True, tmp)
  Next
  .Range("A1").Resize(UBound(myData, 1)).Value = myData
  End With
End Sub

 

[addistexan]

I think it change but for now I’m only seeing long pattern such as 2001:db8:85a3::8a2e:370:7334: The difference is an extra section and divided by “:” rather than “.

I added a small cheat. Can you try this one:

Sub test()
Dim ipList As Object, ipListArr As Variant, lRow As Long, listItem As Variant, myData As Variant, tmp As Variant, j As Long, octes As String
  Set ipList = CreateObject("Scripting.Dictionary")
  With Worksheets("Sheet2")
  lRow = .Cells(Rows.Count, "A").End(xlUp).Row
  ipListArr = .Range("A1:A" & lRow)
  End With
  For Each listItem In ipListArr
    If Not ipList.Exists(Trim(listItem)) Then
      ipList.Add Trim(listItem), 1
    End If
  Next

  With Worksheets("Sheet1")
  lRow = .Cells(Rows.Count, "A").End(xlUp).Row
  myData = .Range("A1:A" & lRow)
  For i = 1 To UBound(myData, 1)
    tmp = Split(myData(i, 1), ",")
    For j = 0 To UBound(tmp)
      octes = Split(Trim(tmp(j)), ".")(0) & "." & Split(Trim(tmp(j)), ".")(1)
      If ipList.Exists(octes) Or Instr(tmp(j), ":") >0 Then 'I added a small condition here. If IP address includes semicolon, then remove. I think none of IPv4 addresses include a semicolon.
        tmp(j) = ""
      End If
    Next
    myData(i, 1) = Application.TextJoin(",", True, tmp)
  Next
  .Range("A1").Resize(UBound(myData, 1)).Value = myData
  End With
End Sub

Thank you so much. I will try tomorrow and let you know. (I’m overseas at the moment and so about to go to sleep for night.)