Extraire chiffre avec décimale VBA

Version imprimable

Bonjour,
Je fais appel à vous car je suis un peu bloqué.
avez vous un code VBA ou une forule qui permettrait d'extraire uniquement le chiffre à virgule dans un texte?
Exemple:
libéllés placés sur range("A")
ABN AMRO BANK NV 3.375% 21/01/2014 -----> extraire dans B2     3.375 
AREVA 4.625% 05/10/2017 ----> extraire dans B3             4.625
AUCHAN SA 4.75% 15/04/15 *EUR ---->extraire dans B4          4.75 
AUTOROUTES PARIS RHIN-RH 5% 12/01/2017 ---->extraire dans B5    5 
BANQUE POP 2.625% 07/12/2012 --->extraire dans B6          2.625
BAYERISCHE 3.5% 08/10/13 *EUR ---> extraire dans B7     3.5
et quand il n'ya pas de chiffre à virgule dans la ligne (ne rien mettre et passer a la ligne suivante)
Merci de votre aide.

Il y a aura toujours systématiquement la maturité et la devise (ou pas) après le coupon ?
Parce que mon idée est de chercher le "." mais je veux être sûr que ça marche avant de te proposer qq chose.

En fait, il vaudrait mieux chercher le dernier %, sinon, tu n'auras pas les coupons entiers

Bon en l'absence de réponse, voici un code qui marche sur ton exemple :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Public Function ExtraireCoupon(obligation As String) As Double
    Dim char As String * 1
    Dim posPourcent As Integer
    Dim tmpNombre As String
    Dim i As Integer
 
    posPourcent = InStr(obligation, "%")
 
    If posPourcent <> 0 Then
        tmpNombre = ""
        i = posPourcent - 1
        char = Mid(obligation, i, 1)
 
        Do While EstChiffre(char) And i > 0
            tmpNombre = char & tmpNombre
 
            i = i - 1
            char = Mid(obligation, i, 1)
        Loop
    End If
 
    ExtraireCoupon = Val(tmpNombre)
End Function
 
Private Function EstChiffre(c As String) As Boolean
    If Len(c) <> 1 Then Err.Raise 1001, "EstChiffre", "Ne s'applique qu'à un caractère"
    EstChiffre = (Asc(c) >= 48 And Asc(c) <= 57) Or Asc(c) = 46
End Function

05/01/2012, 16h02
Maxgad

extraction

Merci infiniment ca marche nickel
comment je peux intégrer cette fonction à ma macro qui traite plusieurs fichiers
j utilise Call dans le module principale ?
05/01/2012, 16h05
ZebreLoup

C'est une fonction et pas une procédure, il ne faut donc pas faire de Call.

Il faudrait faire un truc du style

Code:

Range("B1").Value = ExtraireCoupon(Range("A1").Value)

J'ai mis des Range en dur ici, mais ça peut être dans une boucle ou autre.
05/01/2012, 16h19
Maxgad

Extraction

Est ce que je peux abuser de votre savoir
Promis je vais bosser les fonctions...je vous l'accorde c'est un peu facile mais j'en ai vraiment besoin
Je pourrais faire la meme extraction mais des dates d'echéances ?

En supposant que c'est toujours après le coupon et au format Jour/Mois/Annee :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Public Function ExtraireMaturite(obligation As String) As Date
    Dim char As String * 1
    Dim tmpPos As Integer
    Dim tmpDate As String
    Dim tabDate As Variant
    Dim jour, mois, annee As Integer
 
    tmpPos = InStr(obligation, "%")
    If tmpPos = 1 Then Exit Function
 
    tmpDate = Mid(obligation, tmpPos + 1, Len(obligation) - tmpPos)
    tmpDate = LTrim(tmpDate)
 
    tmpPos = InStr(tmpDate, " ")
    If tmpPos <> 0 Then tmpDate = Mid(tmpDate, 1, tmpPos - 1)
 
    tabDate = Split(tmpDate, "/")
    If UBound(tabDate) <> 2 Then Exit Function
 
    On Error Resume Next
    jour = CInt(tabDate(0))
    mois = CInt(tabDate(1))
    If Len(tabDate(2)) = 2 Then tabDate(2) = "20" & tabDate(2)
    annee = CInt(tabDate(2))
    If Err.Number <> 0 Then Exit Function
    On Error GoTo 0
 
    ExtraireMaturite = DateSerial(annee, mois, jour)
End Function