Code_NumberTect_Function - Excel Λύσεις
Option Base 0
'© Ioannis Varlamis 2005,2007
Private Const zero As String = "Μηδέν "
Function TextNumber(number As Variant, _
Optional NegativeText As String = "-", _
Optional IntGender As Integer = 3, _
Optional IntMeasurePlural As String, _
Optional IntMeasureSingular As String, _
Optional Separator As String = "και", _
Optional DecCount As Integer = -1, _
Optional DecGender As Integer = 3, _
Optional DecMeasurePlural As String, _
Optional DecMeasureSingular As String, _
Optional DecNoZero As Boolean = False, _
Optional IntNoZero As Boolean = False, _
Optional NoSpace As Boolean = False) As String
Application.Volatile True
If Application.Version < 9 Then GoTo myEnd
If IsDate(number) Then
TextNumber = DateText(number)
GoTo myEnd
End If
Select Case True
Case VBA.IsEmpty(number): GoTo myEnd
Case Not VBA.IsNumeric(number): TextNumber = CVErr(xlErrValue): GoTo myEnd
Case Application.IsLogical(number): TextNumber = CVErr(xlErrValue): GoTo myEnd
Case VBA.IsError(number): TextNumber = CVErr(xlErrValue): GoTo myEnd
End Select
Dim R(0 To 14) As Variant
Dim HD As Variant
Dim Y As Variant
Dim numberDEC As Variant: numberDEC = number
Dim M As Integer
Dim j As Integer
Dim IntPart As String
Dim DecPart As String
Dim dekata As String: dekata = "Δέκατα"
Dim dekato As String: dekato = "Δέκατο"
Dim sta As String: sta = "στά"
Dim sto As String: sto = "στό"
HD = VBA.Array("", "Δέκατα", _
"Εκατοστά", "Χιλιοστά", _
"Δεκάκις Χιλιοστά", "Εκατοντάκις Χιλιοστά", _
"Εκατομμυριοστά", "Δεκάκις Εκατομμυριοστά", _
"Εκατοντάκις Εκατομμυριοστά", "Δισεκατομμυριοστά", _
"Δεκάκις Δισεκατομμυριοστά", "Εκατοντάκις Δισεκατομμυριοστά", _
"Τρισεκατομμυριοστά", "Δεκάκις Τρισεκατομμυριοστά", _
"Εκατοντάκις Τρισεκατομμυριοστά", "Τετράκις Εκατομμυριοστά")
If Int(Abs(number)) = 1 And IntMeasureSingular "" _
Then IntMeasurePlural = IntMeasureSingular
IntPart = IntText(number, NegativeText, IntGender) & IntMeasurePlural
numberDEC = Abs(numberDEC)
numberDEC = Format(numberDEC, "0.000000000000000")
For j = 14 To 0 Step -1
R(j) = Mid(numberDEC, Len(numberDEC) - 14 + j, 1)
Next
numberDEC = VBA.Join(R, "")
Select Case True
Case DecCount = -1 And numberDEC = 0
DecCount = 0
DecMeasurePlural = ""
DecMeasureSingular = ""
Case DecCount = -1 And numberDEC 0
Y = numberDEC
Do
Y = Y / 10
M = M + 1
Loop While Y = Int(Y)
DecCount = 15 - M + 1
DecMeasurePlural = ""
DecMeasureSingular = ""
DecGender = 3
End Select
numberDEC = VBA.Left(numberDEC, DecCount)
If numberDEC = 1 And DecMeasureSingular "" Then DecMeasurePlural = DecMeasureSingular
Select Case True
Case DecCount = 0
Case DecMeasurePlural ""
DecPart = IntText(numberDEC, "", DecGender) & DecMeasurePlural
Case DecMeasurePlural = ""
DecPart = IntText(numberDEC, "", DecGender) & HD(DecCount)
If numberDEC = 1 And DecMeasureSingular = "" Then
DecPart = Replace(DecPart, dekata, dekato)
DecPart = Replace(DecPart, sta, sto)
End If
End Select
Separator = ChrW(32) & Separator & ChrW(32)
If DecCount = 0 Then Separator = ""
If DecNoZero = True Then
If VBA.Left(DecPart, 5) = RTrim(zero) Then Separator = "": DecPart = ""
End If
If IntNoZero = True Then
If IntPart = NegativeText & zero Then Separator = "": IntPart = NegativeText
End If
TextNumber = Application.WorksheetFunction.Trim(IntPart & Separator & DecPart)
If NoSpace = True Then TextNumber = _
Application.WorksheetFunction.Substitute(TextNumber, " ", "")
myEnd:
End Function
Private Function IntText(numberINT As Variant, _
Optional NegativeText As String = "-", _
Optional GenderINT As Integer = 3) As String
Dim Tm As Variant
Dim Am As Variant
Dim Fm As Variant
Dim tt As Variant
Dim AFt As Variant
Dim TAFd As Variant
Dim Te As Variant
Dim Ae As Variant
Dim Fe As Variant
Tm = VBA.Array("", "Ένα ", "Δύο ", "Τρία ", "Τέσσερα ", _
"Πέντε ", "Έξι ", "Επτά ", "Οκτώ ", "Εννέα ")
Am = VBA.Array("", "Ένας ", "Δύο ", "Τρεις ", "Τέσσερις ", _
"Πέντε ", "Έξι ", "Επτά ", "Οκτώ ", "Εννέα ")
Fm = VBA.Array("", "Μία ", "Δύο ", "Τρεις ", "Τέσσερις ", _
"Πέντε ", "Έξι ", "Επτά ", "Οκτώ ", "Εννέα ")
tt = VBA.Array("Δέκα ", "Έντεκα ", "Δώδεκα ", "Δεκατρία ", "Δεκατέσσερα ", _
"Δεκαπέντε ", "Δεκαέξι ", "Δεκαεπτά ", "Δεκαοκτώ ", "Δεκαεννέα ")
AFt = VBA.Array("Δέκα ", "Έντεκα ", "Δώδεκα ", "Δεκατρείς ", "Δεκατέσσερις ", _
"Δεκαπέντε ", "Δεκαέξι ", "Δεκαεπτά ", "Δεκαοκτώ ", "Δεκαεννέα ")
TAFd = VBA.Array("", "Δέκα ", "Είκοσι ", "Τριάντα ", "Σαράντα ", _
"Πενήντα ", "Εξήντα ", "Εβδομήντα ", "Ογδόντα ", "Ενενήντα ")
Te = VBA.Array("", "Εκατόν ", "Διακόσια ", "Τριακόσια ", "Τετρακόσια ", _
"Πεντακόσια ", "Εξακόσια ", "Επτακόσια ", "Οκτακόσια ", "Εννιακόσια ")
Ae = VBA.Array("", "Εκατόν ", "Διακόσιοι ", "Τριακόσιοι ", "Τετρακόσιοι ", _
"Πεντακόσιοι ", "Εξακόσιοι ", "Επτακόσιοι ", "Οκτακόσιοι ", "Εννιακόσιοι ")
Fe = VBA.Array("", "Εκατόν ", "Διακόσιες ", "Τριακόσιες ", "Τετρακόσιες ", _
"Πεντακόσιες ", "Εξακόσιες ", "Επτακόσιες ", "Οκτακόσιες ", "Εννιακόσιες ")
Dim ekato As String: ekato = "Εκατό "
Dim ekaton As String: ekaton = "Εκατόν "
Dim Tx As String: Tx = "Χίλια "
Dim Ax As String: Ax = "Χίλιοι "
Dim Fx As String: Fx = "Χίλιες "
Dim xx As String: xx = "Χιλιάδες "
Dim mill As String: mill = "Ένα Εκατομμύριο "
Dim mills As String: mills = "Εκατομμύρια "
Dim billion As String: billion = "Δις "
Dim trillion As String: trillion = "Τρις "
Dim V(0 To 14) As Variant
Dim apart As String, bpart As String, cpart As String
Dim dpart As String, epart As String, totalpart As String
Dim oSgn As Integer, oLen As Integer, i As Integer
oSgn = Sgn(numberINT)
numberINT = Abs(numberINT)
numberINT = Format(numberINT, "0.000000000000000")
numberINT = Int(numberINT)
oLen = Len(numberINT)
If oLen > 15 Then IntText = CVErr(xlErrValue): GoTo myEnd
For i = 0 To oLen - 1
V(15 - oLen + i) = Mid(numberINT, i + 1, 1)
Next
If V(1) + V(2) = 0 Then Te(1) = ekato
Select Case True
Case V(0) + V(1) + V(2) = 0
Case V(1) = 1
epart = Te(V(0)) & tt(V(2)) & trillion
Case Else
epart = Te(V(0)) & TAFd(V(1)) & Tm(V(2)) & trillion
End Select
Te(1) = ekaton
If V(5) + V(4) = 0 Then Te(1) = ekato
Select Case True
Case V(3) + V(4) + V(5) = 0
Case V(4) = 1
dpart = Te(V(3)) & tt(V(5)) & billion
Case Else
dpart = Te(V(3)) & TAFd(V(4)) & Tm(V(5)) & billion
End Select
Te(1) = ekaton
If V(7) + V(8) = 0 Then Te(1) = ekato
Select Case True
Case V(6) + V(7) + V(8) = 0
Case V(6) + V(7) = 0 And V(8) = 1
cpart = mill
Case V(7) = 1
cpart = Te(V(6)) & tt(V(8)) & mills
Case Else
cpart = Te(V(6)) & TAFd(V(7)) & Tm(V(8)) & mills
End Select
If GenderINT = 1 Then Tm = Am: tt = AFt: Te = Ae: Tx = Ax
If GenderINT = 2 Then Tm = Fm: tt = AFt: Te = Fe: Tx = Fx
Te(1) = ekaton
If V(11) + V(10) = 0 Then Fe(1) = ekato
Select Case True
Case V(9) + V(10) + V(11) = 0
Case V(9) + V(10) = 0 And V(11) = 1
bpart = Tx
Case V(10) = 1
bpart = Fe(V(9)) & AFt(V(11)) & xx
Case Else
bpart = Fe(V(9)) & TAFd(V(10)) & Fm(V(11)) & xx
End Select
Te(1) = ekaton
If V(14) + V(13) = 0 Then Te(1) = ekato
If V(13) = 1 Then apart = Te(V(12)) + tt(V(14)) _
Else: apart = Te(V(12)) & TAFd(V(13)) & Tm(V(14))
totalpart = epart & dpart & cpart & bpart & apart
If numberINT = 0 Then totalpart = zero
If oSgn = -1 Then NegativeText = NegativeText & " " Else NegativeText = ""
IntText = NegativeText & totalpart
myEnd:
End Function
Private Function DateText(mydate As Variant) As String
Dim oday As Integer: oday = Day(mydate)
Dim omonth As Integer: omonth = Month(mydate)
Dim oyear As Integer: oyear = Year(mydate)
Dim VMONTH As Variant
VMONTH = VBA.Array("", "Ιανουαρίου", "Φεβρουαρίου", "Μαρτίου", _
"Απριλίου", "Μαΐου", "Ιουνίου", "Ιουλίου", _
"Αυγούστου", "Σεπτεμβρίου", "Οκτωβρίου", _
"Νοεμβρίου", "Δεκεμβρίου")
DateText = IntText(oday, "", 2) & VMONTH(omonth) & ", " & IntText(oyear, "", 3)
End Function
................
................
In order to avoid copyright disputes, this page is only a partial summary.
To fulfill the demand for quickly locating and searching documents.
It is intelligent file search solution for home and business.
Related download
- microsoft excel guide
- comma semicolon and vba strings ntnu
- answers to chapters 1 2 3 4 5 6 7 8 9 end of chapter
- string functions
- code numbertect function excel Λύσεις
- writing visual basic programs in excel
- working with variables in excel vba furman university
- details on excel s rand and fmrg
- visual basic for applications vba in microsoft excel 97
Related searches
- code function excel
- excel function for mortgage calculation
- excel function mortgage payment
- excel value function example
- excel rate function formula
- excel function code
- sumif function excel for texts
- excel if function to change cell color
- excel if function with color
- code function in excel
- excel substitute function multiple values
- define excel function codes