• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Function Getal naar tekst (zegge in euro's) en VBA opslaan als

Status
Niet open voor verdere reacties.
oceanrace

oceanrace

Gebruiker
Lid geworden
14 mei 2008
Berichten
198
Hallo,
Deze goed werkende code dat een getal omzet naar "zegge in euro" wordt met de code eronder helaas gewist.

Code: 
Option Explicit
Option Compare Text

Dim eh$(99)
Dim vv$(12)

Function getaltekst(getal As Variant) As String
  Dim heel, deel    'decimal variants
  Dim txt$, n%      'string/int
  vulArrays
  heel = Int(CDec(Abs(getal)))
  deel = CDec(Abs(getal)) - heel

  txt = IIf(Sgn(getal) < 0, "min ", "") & _
    IIf(heel = 0, IIf(deel = 0, "nul", ""), spel(heel))

  If deel <> 0 Then
    txt = txt & IIf(heel = 0, "", " en ")
    n = Len(Mid(deel, 3))
    'boven miljoenste per macht van 3
    n = n + IIf(n < 6, 0, (3 - n Mod 3) Mod 3)
    deel = deel * (10 ^ n)
    txt = txt & spel(deel) & " " & _
      Trim(Replace(spel(10 ^ n), "een", "")) & _
      IIf(n = 1, "de", "ste")
  End If

  getaltekst = txt
End Function



Function spel$(n)
  Dim t$, tmp$, B$, b1$, b2$
  Dim i%, s%, hv%, dv%

  t = CStr(n)
  'blokje van 4 bij getal tm 9999
  s = IIf(Len(t) = 4, 4, 3)
  'met nullen vullen tot lengte een veelvoud is van 3
  t = String((s - Len(t) Mod s) Mod s, "0") & t

  For i = 1 To Len(t) Step s
    tmp = Mid(t, i, s)
    b1 = Left(tmp, Len(tmp) - 2)
    hv = IIf(Right(b1, 1) = 0, 3, 2)    'duizend/honderd
    b1 = IIf(Right(b1, 1) = 0, Left(b1, 1), b1) 'idem

    b1 = xx(b1)
    b1 = IIf(b1 = "een", " ", b1)       'geen eenhonderd
    b1 = b1 & IIf(b1 = "", "", vv(hv))  'plak veelvoud

    b2 = Right(tmp, 2)
    dv = Len(t) - i - (s - 1)           'duizendvoud
    b2 = xx(b2)

    'spatiëring
    'optioneel EN voor getal tm 12
    b2 = IIf(dv = 0 And b1 <> "" And _
      Right(tmp, 2) > 0 And Right(tmp, 2) <= 12, _
      "en " & b2, b2)
    B = Trim(b1 & " " & b2) & " "
    'geen spatie veelvoud duizend hfdtelwoord tm honderd
    If (dv = 3 And Right(tmp, 2) = "00") Then B = Trim(B)
    'geen spatie veelvoud honderd
    If (dv = 3 And tmp < 100) Then B = Trim(B)

    spel = Trim(spel & " " & B & IIf(tmp = "000", "", vv(dv)))
  Next
End Function

Private Function xx$(n$)
'spelt tm 99
  If eh(n) <> "" Then
    xx = eh(n)
  Else
    xx = eh(Right(n, 1)) & _
      IIf(Left(n, 1) = 1 Or Right(n, 1) = 0, "", _
        IIf(Right(xx, 1) = "e", "ën", "en")) & _
      IIf(eh(Left(n, 1) * 10) <> "", eh(Left(n, 1) * 10), _
        eh(Left(n, 1)) & vv(1))
  End If
  xx = Trim(xx)
End Function

Private Sub vulArrays()
  eh(0) = " "
  eh(1) = "een"
  eh(2) = "twee"
  eh(3) = "drie"
  eh(4) = "vier"
  eh(5) = "vijf"
  eh(6) = "zes"
  eh(7) = "zeven"
  eh(8) = "acht"
  eh(9) = "negen"
  eh(10) = "tien"
  eh(11) = "elf"
  eh(12) = "twaalf"
  eh(13) = "dertien"
  eh(14) = "veertien"
  eh(20) = "twintig"
  eh(30) = "dertig"
  eh(40) = "veertig"
  eh(80) = "tachtig"
  vv(1) = "tig"
  vv(2) = "honderd"
  vv(3) = "duizend"
  vv(6) = "miljoen"
  vv(9) = "miljard"
  vv(12) = "biljoen"
End Sub

Function GetalEuro(getal As Variant) As String
  Dim heel, deel    'decimal variants
  Dim txt$, n%      'string/int
  vulArrays
  heel = Int(CDec(Abs(getal)))
  deel = Round(CDec(Abs(getal)) - heel, 2)
  txt = IIf(Sgn(getal) < 0, "min ", "") & _
    IIf(heel = 0, IIf(deel = 0, "nul", ""), spel(heel))
  If heel > 0 Then txt = txt & IIf(deel = 0, " euro", " euro en ")
  If deel <> 0 Then
    deel = Int(Abs(deel * 100))
    txt = txt & spel(deel) & " cent"
  End If
  GetalEuro = txt
End Function

VBA code opslaan zonder formules en vba (goed werkend):

Code: 
Sub Opslaanzonderformulesmatrix()
  Dim Sh As Shape
  Dim strFileName As Variant, strPath As String
        If Application.Version = "14.0" Then
        MsgBox "Je gebruikt Excel 2010, opslaan via XLS button kan problemen geven." & vbCrLf & _
        "Advies: Gebruik de XPS button om op te slaan." & vbCrLf & _
        "" & vbCrLf & _
        "Dit formulier werkt optimaal in Excel 2003!", vbInformation + vbOKOnly, "Controle Excel versie"
    ElseIf Application.Version = "12.0" Then
        MsgBox "Je gebruikt Excel 2007, opslaan via XLS button kan problemen geven." & vbCrLf & _
        "Advies: Gebruik de XPS button om op te slaan." & vbCrLf & _
        "" & vbCrLf & _
        "Dit formulier werkt optimaal in Excel 2003!", vbInformation + vbOKOnly, "Controle Excel versie"
    End If
  Dim VBProj As VBIDE.VBProject, VBComp As VBIDE.VBComponent, CodeMod As VBIDE.CodeModule
  strFileName = Application.GetSaveAsFilename(InitialFileName:=strPath & [A7], _
                                              FileFilter:="Excel 2000 - 2003 Werkblad (*.xls), *.xls", _
                                              FilterIndex:=2, Title:="Opslaan als excel document (alleen werkblad matrix zonder formules)")
  If strFileName = False Then

    MsgBox "De matrix is niet opgeslagen!", vbInformation + vbOKOnly, "Opslaan geannuleerd..."
  Else
  Call ClearClipboard
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.DisplayStatusBar = True
  Application.Statusbar = "Bezig met opslaan, even geduld a.u.b..."
      ActiveSheet.Copy
      With ActiveWorkbook
      With .Sheets("matrix")
        .Unprotect
        .UsedRange.Value = .UsedRange.Value
       For Each Sh In .Shapes
       If Not Application.Intersect(Sh.TopLeftCell, .Range("AA1:AX100")) Is Nothing Then
         Sh.Delete 'verwijderd alle plaatjes in de range
       End If
    Next Sh
        End With
     Set VBProj = .VBProject
     For Each VBComp In VBProj.VBComponents
            If VBComp.Type = vbext_ct_Document Then
                Set CodeMod = VBComp.CodeModule
                With CodeMod
                    .DeleteLines 1, .CountOfLines
                End With
            Else
                VBProj.VBComponents.Remove VBComp
            End If
        Next VBComp
      .SaveAs Filename:=strFileName
  Application.Statusbar = "Opgeslagen als  " & strFileName
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
      End With
      a = MsgBox("Wil je de matrix printen?" & vbCrLf & _
            "De opgeslagen matrix wordt vervolgens" & vbCrLf & _
            "afgesloten om terug te gaan naar het origineel. ", vbQuestion + vbYesNo, "Gelukt, de matrix is opgeslagen!")
      If a = vbYes Then
   
          Application.Dialogs(xlDialogPrint).Show
      End If
      ActiveWorkbook.Close savechanges:=False
  End If
End Sub

Probleem is dus dat de eerste code "zegge" verdwijnt na opslaan als nieuw bestand.
Iemand tips?

Groet,
Bas
 
Laatst bewerkt:
Opslaan in Excel 2007 geen probleem.
Opslaan als Excel 97 ook geen probleem.
 

Bijlagen

Volgens mij doe je dat expliciet toch?

Code: 
     Set VBProj = .VBProject
     For Each VBComp In VBProj.VBComponents
            If VBComp.Type = vbext_ct_Document Then
                Set CodeMod = VBComp.CodeModule
                With CodeMod
                    .DeleteLines 1, .CountOfLines
                End With
            Else
                VBProj.VBComponents.Remove VBComp
            End If
        Next VBComp

hier wordt alle VBA code gewist
 
Ik bedoel eigenlijk dat de "zegge" in het bestand zelf verdwijnt na opslaan.
Dat had ik niet helemaal duidelijk gemaakt mischien.

Als ik eerst de betreffende cel kopieer en vervolgens waarden plak dan blijft hij wel staan. Maar dan moet ik dat altijd handmatig doen.

Dus voordat hij de code wist, eerst de cel kopieren en waarden plakken.
 
Laatst bewerkt:
Je kunt natuurlijk een copy/paste special uitvoeren. Maar bij mij blijft de tekst wel netjes staan, pas als je een enter geeft op een plaats met een formule gaat het fout. Ik save overigens niet met je save routine, maar ik zie niet direct iets wat het zou aanpassen.

.UsedRange.Value = .UsedRange.Value doet denk ik niet wat je verwacht.

Code: 
for each cell in .UsedRange
     cell.value = cell.value
next cell
 
Met die methode duurt opslaan ontzettend lang, hij doorloopt alle cellen daarmee.
 
Even applicatie op "application.calculation = xlCalculationManual" zetten. Dan zou het als een trein moeten gaan
 
Gebruik dan ipv UsedRange eens een welbepaald bereik en kijk of dit enige verbetering geeft.
 
Hoi Rudi, dat werkt ook niet.
De zin met "zegge" verdwijnt nog steeds na opslaan.
 
Ik heb je vraag eens grondiger gelezen en het is volkomen logisch dat je zin verdwijnt. Je maakt een kopie van een werkblad, maar de module met de functies wordt niet meegekopieërd dus kan je zin nooit blijven staan omdat deze ontbreken. Je kan dus ofwel in je origineel de formule omzetten in een vaste waarde, kopieëren en daarna de formule terug in de cel plaatsen in je origineel of de kopie maken, de module met functies importeren in je nieuwe workbook, omzetten in vaste waarde en module verwijderen.
 
Dat snap ik, daarom zoek ik een manier om te kopiëren in een vaste waarde voordat de module gewist wordt.
En dat is wat me niet lukt...
 
Je gebruikt het actieve workbook om de modules te wissen, maar op dat moment is het nieuw gekopieërde werkblad het actieve workbook en daarin bevindt zich geen module met de functies :rolleyes: en is er al geen resultaat meer aanwezig maw op het moment van kopieëren is er al geen regel meer aanwezig.
 
Ik kan misschien eerst het actieve werkblad kopiëren naar vaste waarden, daarna opslaan en modules wissen. Ik sluit het complete bestand namelijk altijd nadat ik het actieve werkblad heb opgeslagen.
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan