Option Base 1
Sub qwerty()
    Dim a() As Variant
    Dim b() As Variant
    Dim c() As Variant
    Dim abc() As Variant
     
    Application.ScreenUpdating = False
    ra = Cells(65000, 1).End(xlUp).Row
    rb = Cells(65000, 2).End(xlUp).Row
    rc = Cells(65000, 3).End(xlUp).Row
    a() = Range("A1:A" & ra).Value
    b() = Range("B1:B" & rb).Value
    c() = Range("C1:C" & rc).Value
     
    n = 0
    For i = 1 To ra
        flg = False
        For j = 1 To n
           If abc(j) = a(i, 1) Then
              flg = True
           End If
        Next j
        If Not flg Then
           n = n + 1
           ReDim Preserve abc(n)
           abc(n) = a(i, 1)
        End If
    Next i
     
    For i = 1 To rb
        flg = False
        For j = 1 To n
           If abc(j) = b(i, 1) Then
              flg = True
           End If
        Next j
        If Not flg Then
           n = n + 1
           ReDim Preserve abc(n)
           abc(n) = b(i, 1)
        End If
    Next i
     
    For i = 1 To rc
        flg = False
        For j = 1 To n
           If abc(j) = c(i, 1) Then
              flg = True
           End If
        Next j
        If Not flg Then
           n = n + 1
           ReDim Preserve abc(n)
           abc(n) = c(i, 1)
        End If
    Next i
     
    ' сортировка ip адресов, если не нужна, удалите
    For i = 1 To n - 1
       For j = i + 1 To n
          If abc(i) > abc(j) Then
             tmp = abc(i)
             abc(i) = abc(j)
             abc(j) = tmp
          End If
       Next j
    Next i
    ' конец сортировки
     
    Columns("F:I").ClearContents
    For i = 1 To n
       Cells(i, 6).Value = abc(i)
       cnt = 0
       For j = 1 To ra
           If abc(i) = a(j, 1) Then
              cnt = cnt + 1
           End If
       Next j
       Cells(i, 7).Value = cnt
       cnt = 0
       For j = 1 To rb
           If abc(i) = b(j, 1) Then
              cnt = cnt + 1
           End If
       Next j
       Cells(i, 8).Value = cnt
       cnt = 0
       For j = 1 To rc
           If abc(i) = c(j, 1) Then
              cnt = cnt + 1
           End If
       Next j
       Cells(i, 9).Value = cnt
    Next i
    Application.ScreenUpdating = True
End Sub

Public Sub CreateReport()
      Dim pDict As Object, pSheet As Worksheet
      Dim vData As Variant, arrOut() As Variant
      Dim iRow As Long, iCol As Long, idRow As Long
      Dim LRow As Long, LCol As Long, curVal As Variant
      Set pSheet = ActiveSheet
      Set pDict = CreateObject("Scripting.Dictionary")
      vData = pSheet.UsedRange.Value: idRow = 0
      LRow = UBound(vData): LCol = UBound(vData, 2)
      ReDim arrOut(1 To LRow * LCol, 1 To LCol + 1)
      For iCol = 1 To LCol
          For iRow = 1 To LRow
              curVal = Trim$(CStr(vData(iRow, iCol)))
              If curVal <> "" Then
                  If pDict.Exists(curVal) Then
                      idRow = pDict(curVal)
                      arrOut(idRow, iCol + 1) = arrOut(idRow, iCol + 1) + 1
                  Else
                      idRow = idRow + 1
                      pDict.Add curVal, idRow
                      arrOut(idRow, 1) = curVal
                      arrOut(idRow, iCol + 1) = 1&
                  End If
              End If
          Next
      Next
      Set pSheet = Worksheets.Add
      pSheet.Range(pSheet.Cells(1, 1), pSheet.Cells(LRow * LCol, LCol + 1)).Value = arrOut
      pSheet.Range(pSheet.Cells(1, 1), pSheet.Cells(LRow * LCol, LCol + 1)).EntireColumn.AutoFit
End Sub