Extraction de chiffre par VBA

Question

Bonjour,

J'ai des données qui sont structurées en fichier Excel. J'aimerais bien faire l'extraction des pourcentages qui sont dans une de mes colonnes. 

Je vous donne un exemple du contenu dans ces cellules:

At 31-Dec-2008: Roberto (11.899%) Antonio (23.798%); Maria (11.899%) ; Jose (23.798%) ; Martin (23.798%) , Diego (4.808%)

J'ai trouvé un programme VBA pour l'extraction des pourcentages, qui est comme suit:

---

Public Function wExtractPercent(sInput) As Double

    If IsNumeric(sInput) Then

        wExtractPercent = sInput

    Else

        end_position = InStr(sInput, "%")

        For i = end_position To 1 Step -1

            If Mid(sInput, i, 1) = " " Then

                start_position = i

                Exit For

            End If

        Next

        If start_position = 0 Then

            wExtractPercent = Left(sInput, end_position - 1) / 100

        Else

            wExtractPercent = Mid(sInput, start_position, end_position - start_position) / 100

        End If

    End If

End Function

---

Ce programme fonctionne bien avec quelques imperfections:

Imperfection 01: Avant d'appliquer la fonction wExtractPercent, il faut nettoyer le contenu de la cellule des parenthèses "(" et ")"

Imperfection 02: Avant d'appliquer la fonction wExtractPercent, il faut remplacer le point du pourcentage "." par ","

Imperfection 03: Le programme ci-dessous, lit juste le premier pourcentage dans le contenu et ignore le reste des pourcentages.

Je vous donne ma démarche actuelle pour l'extraction des pourcentages:

Étape 01: Je convertis ma colonne en plusieurs afin d'obtenir un pourcentage dans chaque colonne et non pas plusieurs;

Étape 02: je remplace les parenthèses "(" et ")" par des espaces " ";

Étape 03: je remplace "." par "," ;

Étape 04: j'applique finallement  la fonction wExtractPercent qui me donne le pourcentage qui se trouve dans chaque cellule.

Quatre étape ce n'est pas beaucoup pour quelques cellules, mais le problème c'est que j'ai des centaines de milliers de cellules à traiter, et cela devient fastidieux est aussi lourd pour excel.

Ma question est donc la suivante:

Pourriez-vous m'aider à améliorer mon programme/ma fonction VBA ci-dessus pour faire l'extraction en moins d'étapes et d'une façon plus conviviale. Cela me rendra grand service.

Merci d'avance

Answer 1

Bonjour

Je n'ai pas de doc particulière à te recommander.

Comme dans ma première réponse je te disais que c'était surement optimisation.

J'étais resté sur le principe d'une fonction vu que partais de là.

Le VBA est lent comme langage (interprété) et dans ce cas c'est pire car en utilisant une fonction ainsi Excel recherche 10 fois les 10 occurrences et ce pour chaque ligne !

1 millions de lignes = 100 millions de recherches !

Je te propose ceci à tester :

Sub Extraction()

    Dim LigneDeb As Long

    Dim reg As Object

    Dim Resultats As Object

    Dim lg As Long

    Dim i As Byte

    Application.ScreenUpdating = False    

    LigneDeb = Selection.Rows(1).Row

    Set reg = CreateObject("vbscript.regexp")

    reg.Global = True

    reg.Pattern = "\d+.?\d*%"

    For lg = 1 To Selection.Rows.Count

        Set Resultats = reg.Execute(Range("B" & LigneDeb + lg - 1))  'Colonne B

            For i = 1 To Resultats.Count

                 Cells(lg + LigneDeb - 1, i + 2) = Replace(Replace(Resultats.Item(i - 1), ".", ","), "%", "") / 100 '+2 Pour colonne C, +3 pour colonne D....

            Next

    Next

    Set reg = Nothing

   Application.ScreenUpdating = True

End Sub

C'est une procédure, tu sélectionnes les données colonne B (Sélection de la 1ere cellule puis CTRL+MAJ+Flèche Bas) puis tu exécutes la procédure qui va générer les valeurs en colonne C, D,....

C'est plus rapide (10s pour 100 000 lignes).

Answer 2

Voici

Je m'était trompé sue le pattern

\d+.?\d*%

\d =>(1 chiffre)

+  =>(répété 1 ou plusieurs fois)

.    =>(un caractère point)

?   => (répété 0 ou 1 fois)

\d =>(1chiffre)

*   =>(répété 0 ou plusieurs fois)

% =>(un caractère %)

J'ai supprimer le remplacement de la "(" qui était devenu inutile

Function ExtrationPourcentage(Chaine As String, k As Byte) As Single

    Dim reg As Object

    Dim Resultats As Object

    Dim Resultat As String

    Set reg = CreateObject("vbscript.regexp")

    reg.Global = True

    reg.Pattern = "\d+.?\d*%"

    Set Resultats = reg.Execute(Chaine)

    If Resultats.Count <> 0 Then

        Resultat = Replace(Resultats.Item(k - 1), "%", "")

    End If

    ExtrationPourcentage = (Replace(Resultat, ".", ",") / 100)

End Function

Answer 3

Bonsoir Daniel et Arnaud,

D'abord, je vous remercie de prendre le temps pour me répondre. J'apprécie beaucoup.

Toutefois, j'ai essayé d'appliquer les deux codes que vous m'avez fournis...mais sans résultat. Excel me renvoie à chaque fois "#VALEUR!".

J'avoue que mes connaissances en VBA sont vraiment de base. Certes, j'ai beaucoup travaillé avec Excel et ses fonctions, mais je viens de commencer avec VBA (par obligation :)

Pour faire une histoire courte, j'ai commencé ma recherche de solution à mon problème par le code (celui qui porte sur la fonction wExtractPercent) que j'ai mis dans mon premier message et dont j'ai omis de vous mettre la source, et qui est la suivante:

http://access-excel.tips/extract-percentage-from-text/

Après multiples modifications de la cellule (remplacement des parenthèses et du point...), j'appelle ensuite la fonction wExtractPercent, et la valeur sortie par cette fonction porte toujours sur le premier pourcentage de la cellule.

Donc, s'il vous plait, pourriez-vous m'améliorer le code suivant:

---

Public Function wExtractPercent(sInput) As Double

    If IsNumeric(sInput) Then

        wExtractPercent = sInput

    Else

        end_position = InStr(sInput, "%")

        For i = end_position To 1 Step -1

            If Mid(sInput, i, 1) = " " Then

                start_position = i

                Exit For

            End If

        Next

        If start_position = 0 Then

            wExtractPercent = Left(sInput, end_position - 1) / 100

        Else

            wExtractPercent = Mid(sInput, start_position, end_position - start_position) / 100

        End If

    End If

End Function

---

 afin que je puisse extraire par une fonction (ou une procédure) tous les pourcentages qui se trouvent dans la cellule (des pourcentages qui pourraient être séparé par des un trait ou un point virgule ou ...)

Je dispose d'une banque  de plusieurs centaines de milliers de données que je dois traiter et analyser par la suite, et votre aide me rendra grandement service.

Je vous remercie pour votre temps et surtout pour votre expertise.

Answer 4

Bonjour

Travaille directement sur ta chaine

At 31-Dec-2008: Roberto (11.899%) Antonio (23.798%); Maria (11.899%) ; Jose (23.798%) ; Martin (23.798%) , Diego (4.808%)

en se basant sur la règle que les % commencent tous par "(" et on des décimales

K indice de la chaîne à récupérer

Function ExtrationPourcentage(Chaine As String, k As Byte) As Single

    Dim reg As Object

    Dim Resultats As Object

    Dim Resultat As String

    Set reg = CreateObject("vbscript.regexp")

    reg.Global = True

    reg.Pattern = "(\d+.\d+%"

    Set Resultats = reg.Execute(Chaine)

    If Resultats.Count <> 0 Then

        Resultat = Replace(Replace(Resultats.Item(k - 1), "(", ""), "%", "")

    End If

    ExtrationPourcentage = (Replace(Resultat, ".", ",") / 100)

End Function

On doit pouvoir optimiser encore

Answer 5

Bonjour,

J'ai mis le texte en A1. Adapte :

Sub test()

  Dim Tabl1 As Variant, Tabl2 As Variant

  Tabl1 = Split([A1], "(")

  For Each Item In Tabl1

    Tabl2 = Split(Item, ")")

    For i = 0 To UBound(Tabl2)

      If Right(Tabl2(i), 1) = "%" Then

        Tabl2(i) = Replace(Tabl2(i), ".", ",")

        MsgBox Tabl2(i)

      End If

    Next i

  Next Item

End Sub

Cordialement.

Daniel