Extraction de données

Bonjour,

Je souhaite extraire dans l'exemple 1 :

dans deux colonnes séparées, la valeur 16 dans une colonne et la valeur 145 dans une deuxième colonne

Et dans l'exemple 2

1ère colonne : 8

2ème colonne 4

3ème colonne 90

Merci de votre aide.

Bonjour,

A tester :

Option Explicit

Function ExtQte(ByVal Chaine As String, ByVal Position As Integer) As Variant

Dim I As Integer, IndexM As Integer
Dim TabChaine As Variant
Dim ChaineTrouvee As String, ChaineNumerique As String
Dim MatriceValeurs() As Variant

    ExtQte = ""
    IndexM = 0

    If InStr(1, Chaine, " ", vbTextCompare) = 0 Then Exit Function

    TabChaine = Split(Chaine, " ")
    ChaineTrouvee = TabChaine(UBound(TabChaine))
    ChaineNumerique = ""
    For I = 1 To Len(ChaineTrouvee)
        Select Case Mid(ChaineTrouvee, I, 1)
               Case 0 To 9
                    ChaineNumerique = ChaineNumerique & Mid(ChaineTrouvee, I, 1)
               Case Else
                    If ChaineNumerique <> "" Then
                       ReDim Preserve MatriceValeurs(IndexM)
                       MatriceValeurs(IndexM) = ChaineNumerique
                       IndexM = IndexM + 1
                       ChaineNumerique = ""
                    End If

        End Select
    Next I

    If UBound(MatriceValeurs) + 1 >= Position Then ExtQte = CInt(MatriceValeurs(Position - 1))

End Function

Bonjour Lulu, ERIC, Le forum,

@ERIC étant nul en VBA, je me permets de te poser une question, avec ce code, on peut l'utiliser dans n'importe quelle circonstance, EX : 3 pommes coûtent 2,5€ et pèsent 220 grammes. En tout cas, le TOP ! Bravo

Bonjour J-M,

Merci.

bonjour,

un mac2010??? Ici est crée sur un windows-excel365, une sorte de formule matricielle

Function Dimensions(texte)
     sp = Split(texte)     'split on espace
     s = sp(UBound(sp))     'dernier partie
     For I = 40 To 90     'tous les lettres
          Select Case I
               Case 40 To 41, 65 To 87, 89 To 90: s = Replace(s, Chr(I), "", , , vbTextCompare)   'effacer tous les lettres + "(" et ")" sauf le "x"
          End Select
     Next
     Dimensions = Split(s, "x", , vbTextCompare)
End Function

Au cas où il faudrait analyser toute la chaine suite à la remarque de Jmber1972. Chaine contenant une valeur décimale :

Function ExtQte2(ByVal Chaine As String, ByVal Position As Integer) As Variant

Dim I As Integer, IndexM As Integer
Dim TabChaine As Variant
Dim ChaineTrouvee As String, ChaineNumerique As String
Dim MatriceValeurs() As Variant

    ExtQte2 = ""
    IndexM = 0

    ChaineNumerique = ""
    For I = 1 To Len(Chaine)
        Select Case Mid(Chaine, I, 1)
               Case 0 To 9, ","
                    ChaineNumerique = ChaineNumerique & Mid(Chaine, I, 1)
               Case Else
                    If ChaineNumerique <> "" Then
                       ReDim Preserve MatriceValeurs(IndexM)
                       MatriceValeurs(IndexM) = Trim(ChaineNumerique)
                       IndexM = IndexM + 1
                       ChaineNumerique = ""
                    End If

        End Select
    Next I

    If UBound(MatriceValeurs) + 1 >= Position Then ExtQte2 = CDbl(MatriceValeurs(Position - 1))

End Function

SUPERBE Eric, elle fonctionne du tonnerre !! Encore merci !!

La fonction EXTRAIRENOMBRES de Jmber1972 revisitée. Elle fonctionne si les nombres sont séparés par des espaces.

Function EXTRAIRENOMBRES(ByVal Texte As String, ByVal Position As Integer) As Variant

Dim NbNum As Integer
Dim TableauValeurs As Variant, Valeur As Variant

     TableauValeurs = Split(Texte, " ")
     NbNum = 0

     For Each Valeur In TableauValeurs
         If IsNumeric(Valeur) Then NbNum = NbNum + 1
     Next

     If Position > NbNum Then
        EXTRAIRENOMBRES = ""
     Else
        NbNum = 0
        For Each Valeur In TableauValeurs
            Debug.Print Valeur
            If IsNumeric(Valeur) Then
               NbNum = NbNum + 1
               If NbNum = Position Then EXTRAIRENOMBRES = CDbl(Valeur)
            End If
        Next
     End If

End Function

Bonjour

Une solution PowerQuery

re,

les valeurs décimaux, cela ne causait pas de problèmes, mais c'étaient des textes, maintenant ce sont des valeurs, qu'on peut joindre comme un texte

Function Dim_Texte(texte)
     Application.Volatile
     Dim x As Integer
     a = Dimensions(texte)
     For x = 0 To UBound(a)
          Select Case x
               Case 0 To 2: a(x) = Application.Index(Array("longueur", "largeur", "hauteur"), 1 + x) & " : " & Format(a(x), "#,###.#") & " mètre(s)"
          End Select
     Next
     Dim_Texte = Join(a, ", ")
End Function

Bonjour,

Merci infiniment de tout votre travail. Il faudra que je vous demande des explications sur ce module VBA. Mais déjà un grand merci.