Sub MaxMatch()
Dim LRow As Long, LCol As Long, StrData As String, bFnd As Boolean
Dim C As Long, R As Long, I As Long, J As Long, ArrPairs() ' Array
ReDim Preserve ArrPairs(1, 0)
With ActiveSheet
  LRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
  LCol = .Cells.SpecialCells(xlCellTypeLastCell).Column - 1
  For C = 1 To LCol
    For R = 1 To LRow
      StrData = Format(.Cells(R, C).Value, "000") & Format(.Cells(R, C + 1).Value, "000")
      bFnd = False
      For I = 0 To UBound(ArrPairs, 2) - 1
        If StrData = ArrPairs(0, I) Then
          bFnd = True
          ArrPairs(1, I) = ArrPairs(1, I) + 1
          Exit For
        End If
      Next
      I = I + 1
      If bFnd = False Then
        ReDim Preserve ArrPairs(1, I)
        ArrPairs(0, I) = StrData
        ArrPairs(1, I) = 1
      End If
    Next
  Next
  For I = 0 To UBound(ArrPairs, 2) - 1
    If ArrPairs(1, I) > ArrPairs(1, J) Then
      J = I
    End If
  Next
  MsgBox "The greatest paired match frequency is for" & vbCr & _
    Int(ArrPairs(0, J) / 1000) & " & " & ArrPairs(0, J) Mod 1000 & _
    ", with " & ArrPairs(1, J) & " matches."
End With
End Sub