Καλησπέρα έχω κολλήσει στο εξής ,προσπαθώ να φτιάξω στο excel με vba ηλεκτρονική τιμολόγηση .Το έχω ρυθμίσει να μετατρέπει το αριθμητικό ποσό σε ολογράφως ,να το τυπώνει και να το αποθηκεύει σε μορφή excel στον υπολογιστή. Αλλά όταν το τυπώνω δεν εμφανίζει το ολογράφως(#ονομα?) και όταν πηγαίνω να ανοίξω το αποθηκευμένο παρατηρώ ότι δεν κρατάει τη συνάρτηση που το μετατρέπει στο ολογράφως και θα πρέπει να το ξανα ορισω. Υπάρχει τρόπος να το κρατάει και στην αρχική φόρμα και στο αποθηκευμένο αρχειο. Σας επισυνάπτω μέρος του κώδικα.
Κώδικας:Sub NextInvoice() Range("I5").Value = Range("I5").Value + 1 Range("G26").Value = Range("G34") Range("G30").Value = Range("G34") Range("G31").MergeArea.ClearContents Range("G34").MergeArea.ClearContents Range("G38").MergeArea.ClearContents Range("G34").Formula = "=G30-G31" End Sub Sub SaveInvWithNewName() Dim NewFN As Variant ActiveSheet.Copy NewFN = "C:\invoice" & Range("I5").Value & Range("H5").Value & Range("I49").Value & Range("F16").Value & ".xlsm" ActiveSheet.SaveAs NewFN, FileFormat:=xlOpenXMLWorkbookMacroEnabled Application.DisplayAlerts = True ActiveWorkbook.PrintOut copies:=2 ActiveWorkbook.Close SaveChanges:=False NextInvoice End Sub ΣΥΝΑΡΤΗΣΗ ΓΙΑ ΟΛΟΓΡΑΦΩΣ 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(TextNumbe r, " ", "") 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
Εμφάνιση 1-1 από 1
-
07-08-17, 15:30 ΔΕΝ ΜΟΥ ΚΡΑΤΑΕΙ ΤΟ ΟΛΟΓΡΑΦΩΣ ΣΤΗΝ ΑΠΟΘΗΚΕΥΣΗ ΚΑΙ ΣΤΗΝ ΕΚΤΥΠΩΣΗ #1
Παρόμοια Θέματα
-
Το Netflix διαθέσιμο παγκοσμίως - και στην Ελλάδα
Από euri στο φόρουμ ΕιδήσειςΜηνύματα: 2256Τελευταίο Μήνυμα: 02-02-21, 19:37 -
NAS για αποθήκευση (και σύνδεση/προβολή σε SmartTV) ταινιών.
Από lupus_Hegemonia στο φόρουμ Σκληροί δίσκοι, αποθηκευτικά μέσα και λοιπά περιφερειακάΜηνύματα: 137Τελευταίο Μήνυμα: 08-06-17, 01:38 -
Σε windows 10 Pro μου βγάζει στην εκτύπωση απο firefox ιερογλυφικά?
Από stathopon στο φόρουμ Software γενικάΜηνύματα: 2Τελευταίο Μήνυμα: 27-01-17, 11:29 -
Δεν μου εμφανιζει καν το δικτυο ενω απο κιν μπαινω κανονικα!!
Από Manos_Krok στο φόρουμ WindΜηνύματα: 8Τελευταίο Μήνυμα: 19-11-16, 13:45 -
Έχω internet αλλά δεν απαντάει σε ping το router μου όταν το δοκιμάζω από άλλο δίκτυο.
Από Konstantinoz στο φόρουμ ADSLΜηνύματα: 6Τελευταίο Μήνυμα: 28-08-16, 19:59
Bookmarks