'Option Explicit
' ---- need DIMension statements
'See http://www.mvps.org/dmcritchie/excel/sorttcp.htm -- David McRitchie DMcRitchie@msn.com
'Functions: IPSort, IPNorm, ChaptSort
'Subroutines: IPSortSUB, IPNormSUB, IP2Text for European usage
'Reformat TCP/IP address for sorting

Function ChaptSort(cell As String) As String
 'dmcritchie, worksheet.functions, 2004-01-21, #sAGbiE4DHA.2388@TK2MSFTNGP09.phx.gbl
   Dim i As Long, j As Long, n As Long
   Dim oldstr As String, newstr As String
   oldstr = cell
   i = 1
   newstr = ""
reloop:
   j = InStr(Mid(oldstr, i), ".")
   If j > 5 Then
     ChaptSort = "#segment"
     Exit Function
   ElseIf j <> 0 Then
     l = j - l
     newstr = newstr & "." & Left("0000", 5 - j) & Mid(oldstr, i, j - 1)
     i = i + j
     GoTo reloop
   Else
     If Len(oldstr) - i >= 4 Then
        ChaptSort = "#length"
        Exit Function
     Else
       newstr = newstr & "." & Left("0000", 3 - (Len(oldstr) - i)) & Mid(oldstr, i)
     End If
   End If
   ChaptSort = "*" & Mid(newstr, 2)
End Function
Function IPSort(cell)
     oldvalue = cell.Value
     p1 = 0
     p2 = 0
     p3 = 0
     For px = 2 To Len(oldvalue)
        If Mid(oldvalue, px, 1) = "." Then
            If p1 = 0 Then
               p1 = px
               ElseIf p2 = 0 Then p2 = px
               ElseIf p3 = 0 Then p3 = px
            End If
        End If
     Next px
     IPSort = Right("00000" & Mid(oldvalue, 1, p1 - 1), 3) _
        & "." & Right("00000" & Mid(oldvalue, p1 + 1, p2 - p1 - 1), 3) _
        & "." & Right("00000" & Mid(oldvalue, p2 + 1, p3 - p2 - 1), 3) _
        & "." & Right("00000" & Mid(oldvalue, p3 + 1), 3)
End Function


Function IPNorm(cell)
     oldvalue = cell.Value
     p1 = 0
     p2 = 0
     p3 = 0
     For px = 2 To Len(oldvalue)
        If Mid(oldvalue, px, 1) = "." Then
            If p1 = 0 Then
               p1 = px
               ElseIf p2 = 0 Then p2 = px
               ElseIf p3 = 0 Then p3 = px
            End If
        End If
     Next px
     i1 = Mid(oldvalue, 1, p1 - 1) + 0
     i2 = Mid(oldvalue, p1 + 1, p2 - p1 - 1) + 0
     i3 = Mid(oldvalue, p2 + 1, p3 - p2 - 1) + 0
     i4 = Mid(oldvalue, p3 + 1, Len(oldvalue) - p3) + 0
     IPNorm = i1 & "." & i2 & "." & i3 & "." & i4
End Function

Sub IPSortSUB()
   tcells = Selection.Count
  For ix = 1 To tcells   '(0,0) below is same as (False, False)
     'Selection.Item(iX) = "'" & Selection.Item(iX).AddressLocal(0, 0)  Next iX
     oldvalue = Selection.Item(ix)
     p1 = 0
     p2 = 0
     p3 = 0
     For px = 2 To Len(oldvalue)
        If Mid(oldvalue, px, 1) = "." Then
            If p1 = 0 Then
               p1 = px
               ElseIf p2 = 0 Then p2 = px
               ElseIf p3 = 0 Then p3 = px
            End If
        End If
     Next px
     Selection.Item(ix).Value = Right("00000" & Mid(oldvalue, 1, p1 - 1), 3) _
        & "." & Right("00000" & Mid(oldvalue, p1 + 1, p2 - p1 - 1), 3) _
        & "." & Right("00000" & Mid(oldvalue, p2 + 1, p3 - p2 - 1), 3) _
        & "." & Right("00000" & Mid(oldvalue, p3 + 1), 3)
   Next ix
End Sub

Sub IPNormSUB()
   ' Example of use:
   '   =hyperlink("telnet://" & ipnormsub(b1),ipnormsub(b1))
   tcells = Selection.Count
  For ix = 1 To tcells
     oldvalue = Selection.Item(ix)
     p1 = 0
     p2 = 0
     p3 = 0
     For px = 2 To Len(oldvalue)
        If Mid(oldvalue, px, 1) = "." Then
            If p1 = 0 Then
               p1 = px
               ElseIf p2 = 0 Then p2 = px
               ElseIf p3 = 0 Then p3 = px
            End If
        End If
     Next px
     i1 = Mid(oldvalue, 1, p1 - 1) + 0
     i2 = Mid(oldvalue, p1 + 1, p2 - p1 - 1) + 0
     i3 = Mid(oldvalue, p2 + 1, p3 - p2 - 1) + 0
     i4 = Mid(oldvalue, p3 + 1, Len(oldvalue) - p3) + 0
     Selection.Item(ix).Value = i1 & "." & i2 & "." & i3 & "." & i4
   Next ix
End Sub

Sub IP2text()
'DMcRitchie@hotmail.com Jun 2, 1999 excel.programming
'only of use with European Number formatting"
Dim TheCell As Range
Application.ScreenUpdating = False
For Each TheCell In Selection
    With TheCell
       If .HasFormula = False Then
         'If IsNumeric(.Value) Then  -- replaced with
         If Application.IsNumber(.Value) Then
             ccc = Format(.Value, "###,###,###,###")
             .Value = ""
            .NumberFormat = "@"
             .Value = ccc
         End If
       .NumberFormat = "@"
       End If
    End With
Next TheCell
Application.ScreenUpdating = True
End Sub

Function ALPHA_N(strr As String, lenn As Long) As String
  'ALPHA_N, create length N, alpha on left, numeric on right, fill middle zeros
  'David McRitchie, 1999-01-28
  Application.Calculation = xlCalculationManual    'in XL97
  Application.ScreenUpdating = False
  Dim k As Long
  ALPHA_N = strr
  For k = 1 To Len(strr)
    If Mid(strr, k, 1) <= "9" Then
      ALPHA_N = Left(strr, k - 1) & _
        Left("000000000000000", lenn - Len(strr)) & Mid(strr, k, 99)
      GoTo done
    End If
  Next k
done:
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic  'in XL97
End Function

Function NormDigits(cell As String, Optional p As Long) As String
  'dmcritchie, worksheet.functions, 2004-01-21, _
  '     #sAGbiE4DHA.2388@TK2MSFTNGP09.phx.gbl
  'dmcritchie, newuser,  2004-07-01
   Dim i As Long, n As String, s As String
   Dim newstr As String
   s = UCase(Trim(cell))
   If p = 0 Then p = 3
   newstr = ""
   n = ""
reloop:
   For i = 1 To Len(s)
     If Mid(s, i, 1) Like "[0-9]" Then
       n = n & Mid(s, i, 1)
     ElseIf n = "" Then
       newstr = newstr & Mid(s, i, 1)
     Else
       newstr = newstr & Format(n, Left("0000000", p))
       n = ""
       newstr = newstr & Mid(s, i, 1)
     End If
  Next i
  If n <> "" Then newstr = newstr & Format(n, Left("0000000", p))
  NormDigits = newstr
End Function

Function ChemNDigits(cell As String, Optional p As Long) As String
  ' David McRitchie, newusers,  2004-07-01
  ' http://www.mvps.org/dmcritchie/sorting.htm  & tcpip.htm
  ' http://google.com/groups?threadm=uNAGaA5XEHA.2840@TK2MSFTNGP11.phx.gbl
   Dim i As Long, n As String, s As String, c As String
   Dim newstr As String
   s = Trim(cell)
   If p = 0 Then p = 3
   newstr = ""
   n = 0
   '------ end of initialization
   c = Left(s, 1)
   For i = 2 To Len(s)
     If Mid(s, i, 1) Like "[A-Z]" Then
        If c <> "" Then
          newstr = newstr & Left(c & "--", 2)
        End If
        n = Application.WorksheetFunction.Max(1, n)
        newstr = newstr & Format(n, Left("0000000", p))
        n = 0
        c = Mid(s, i, 1)
     ElseIf Mid(s, i, 1) Like "[a-z]" Then
        c = c & Mid(s, i, 1)
     ElseIf Mid(s, i, 1) Like "[0-9]" Then
        If c <> "" Then newstr = newstr & Left(c & "--", 2)
        n = n & Mid(s, i, 1)
        c = ""
     Else
        newstr = newstr & "..error.."
     End If
  Next i
  If c <> "" Then newstr = newstr & Left(c & "--", 2)
  n = Application.WorksheetFunction.Max(1, n)
  newstr = newstr & Format(n, Left("0000000", p))
  ChemNDigits = newstr  'Chemical Nomenclature
End Function

Sub Chem_Coeff_To_Subscript()
   'David Hager, 2002-01-22, programming
   ' http://google.com/groups?selm=uDg8ZVuoBHA.2284%40tkmsftngp05
    Dim fRange As Range
    If Application.Workbooks.Count = 0 Then Exit Sub
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    Application.ScreenUpdating = False
    Set fRange = Selection
    For Each sCell In fRange
        If Not IsEmpty(sCell) Then
            If Left(sCell.Formula, 1) <> "=" Then
                If Not (IsNumeric(sCell)) Then
                    For scount = 1 To Len(sCell)
                        If IsNumeric(sCell.Characters(Start:=scount, _
                              Length:=1).Text) Then
                                 sCell.Characters(Start:=scount, _
                                    Length:=1).Font.Subscript = True
                        End If
                    Next
                End If
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Function StrDomain(cell As Range) As String
 Dim newstr As String
 Dim i As Integer, j As Integer, k As Integer
 newstr = Replace(cell, "//", ".")
 j = 1: k = 0
 For i = 2 To Len(newstr)
   If i + 2 = Len(newstr) Then GoTo done
   If Mid(newstr, i, 1) = "." Then
     k = j
     j = i + 1
   End If
 Next i
done: StrDomain = Mid(cell, k + 1, Len(cell) - k)
End Function