Γιατί μόνο η ROMAN; (συνέχεια)

Στο προηγούμενο σημείωμα είδαμε την συνάρτηση HellenicNumber η οποία αποδίδει την αρχαιοελληνική γραφή των ακέραιων αριθμών έως την μυριάδα (10000).
Η σημερινή συνάρτηση HellenicNumberExtra(n;form;tonos) προσπαθεί να μετατρέψει μεγαλύτερους αριθμούς. Λέω “προσπαθεί” διότι το σύμβολο Μ με μία τελεία πάνω το χρησιμοποιεί για να προσεγγίσει τον τρόπο γραφής των μυριάδων και το σύμβολο Μ με μία τελεία κάτω για να προσεγγίσει τις μυριάδες μυριάδων (εκατό εκατομμύρια). Οδηγός μου η Ιστορία των Ελληνικών Μαθηματικών του Ε. Σταμάτη.
Η συνάρτηση δέχεται ακέραιους αριθμούς από ένα έως ένα τρισεκατομμύριο και εκφράζει τους αριθμούς με 2 τρόπους. Αν ορίσετε το όρισμα format =1 τότε τα σύμβολα των μυριάδων έπονται της τάξης των αριθμών που περιγράφουν και αν ορίσετε format=2, τότε τα σύμβολα Μ προηγούνται της τάξης.
Για να δουλέψει η συνάρτηση πρέπει τον κώδικά της  να τον γράψετε μαζί με τον κώδικα της HellenicNumber. Καλή διασκέδαση.
Function HellenicNumberExtra(n As Double, _
            Optional form As Integer = 1, _
            Optional tonos As Boolean = True) As String
Application.Volatile True
If n <> Int(n) Then HellenicNumberExtra = CVErr(xlErrValue): GoTo telos
Dim strM As String
Dim strMM As String
Dim A As Integer
Dim B As Integer
Dim C As Integer
strM = ChrW(7744)
strMM = ChrW(7746)
Select Case n
Case 0 To 10 ^ 4 - 1
    HellenicNumberExtra = HellenicNumber(n, tonos)
Case 10 ^ 4 To 10 ^ 8 - 1
    A = n Mod 10000
    B = Int(n / 10000)
    If Abs(form) Mod 2 = 1 Then
        HellenicNumberExtra = HellenicNumber(B, False) _
        & strM & HellenicNumber(A, tonos)
    ElseIf Abs(form) Mod 2 = 0 Then
        HellenicNumberExtra = strM & HellenicNumber(B, False) _
                & ChrW(32) & HellenicNumber(A, tonos)
    End If
Case 10 ^ 8 To 10 ^ 12 - 1
    A = n - 10 ^ 4 * Int(n / 10 ^ 4)
    C = Int(n / 10 ^ 8)
    B = (n - A - C * 10 ^ 8) / 10 ^ 4
    If B = 0 Then strM = ""
    If Abs(form) Mod 2 = 1 Then
        HellenicNumberExtra = _
        HellenicNumber(C, False) & strMM _
        & HellenicNumber(B, False) _
        & strM & HellenicNumber(A, tonos)
    ElseIf Abs(form) Mod 2 = 0 Then
        HellenicNumberExtra = _
        strMM & HellenicNumber(C, False) & ChrW(32) _
        & strM & HellenicNumber(B, False) _
        & ChrW(32) & HellenicNumber(A, tonos)
    End If
Case Else
    HellenicNumberExtra = CVErr(xlErrValue)
End Select
HellenicNumberExtra = Application.WorksheetFunction.Trim(HellenicNumberExtra)
telos:
End Function
Αν θέλετε κατεβάστε ένα excel βιβλίο με την συνάρτηση:  VbaHellenicNumberFunction

											
This entry was posted in excel, Συναρτήσεις Χρήστη, VBA and tagged . Bookmark the permalink.