Macro pour extraire caractères d'une cellule

[doudom]

Bonjour,

Je souhaiterais faire une macro manuelle par bouton(voir fichier joint), qui m’extrairerai dans d'autres cellules les caractères (1-3-5-7-9).

J'y arrive avec la fonction STXT, mais le problème est que j'ai déjà une première macro qui réinitialise les lignes, et STXT renvoi après une erreur 'REF'

Donc je souhaiterais pouvoir activer la nouvelle macro seulement après la réinitialisation.

Merci d'avance de votre aide, et si je suis pas assez clair, n'hésitez pas

Doudom

 

[Victor21]

Re : Macro pour extraire caractères d'une cellule

Bonjour, doudom.

Pas vu la première macro (dans un XLSX, c'est normal !)
Données, Convertir, délimité, avec "a" comme séparateur semble faire ce que vous désirez.
L'enregistreur de macro devrait vous sortir le code (à épurer).

 

[doudom]

Re : Macro pour extraire caractères d'une cellule

Bonjour Victor,

Merci de bien vouloir m'aider.
Le fichier joint est juste un fichier exemple.
Désolé mais je tâtonne en VBA, je suis plus habitué aux formules auriez vous un exemple de code ?
Merci d'avance

 

[doudom]

Re : Macro pour extraire caractères d'une cellule

Victor,

J'ai testé vos indications, mais le séparateur n'est pas toujours 'a'
Merci

 

[Victor21]

Re : Macro pour extraire caractères d'une cellule

Re,

Ce que donne le code fourni par l'enregistreur une fois nettoyé :

Range("E2:E6").TextToColumns Destination:=Range("f2"), DataType:=xlDelimited, OtherChar:="a"

 

[doudom]

Re : Macro pour extraire caractères d'une cellule

Re,
Ca fonctionne bien, c'est ce que je recherche, par contre comment inclure d'autres caractères a ne pas tenir compte en plus du 'a'

Cordialement

 

[Victor21]

Re : Macro pour extraire caractères d'une cellule

Re,
L'aide VBA (F1) sur le paramètre "OtherChar" de la méthode "Range.TextToColumns" indique : Si plusieurs caractères sont spécifiés, seul le premier caractère de la chaîne est utilisé ; les autres caractères sont ignorés.
Je ne connais pas la réponse à cette question, mais d'autres que moi viendront probablement ici avec une autre proposition.
Je vous conseille de tenter d'expliciter un peu plus votre question avec plusieurs exemples concrets (sans données confidentielles, bien sûr !)

 

[doudom]

Re : Macro pour extraire caractères d'une cellule

Re,

Ok merci pour votre aide, je continue mes recherches.

Doudom

 

[doudom]

Re : Macro pour extraire caractères d'une cellule

Re,

Grace à Victor21, j'ai avancé dans mes recherches et sa macro est bonne, par contre, je souhaiterais pouvoir exclure plusieurs caractères exemple avec le 'm'(voir fichier).

Merci d'avance

Doudom

 

[david84]

Re : Macro pour extraire caractères d'une cellule

Bonjour,
ci-joint une fonction personnalisée à tester :

Function Doudom(chaine As String, sep As String, rang As Byte) As String
Dim s
s = Split(chaine, sep)
If rang - 1 <= UBound(s) Then Doudom = s(rang - 1)
End Function

1er argument : la chaîne de caractères
2ème argument : le séparateur
Tirer la formule vers la droite.
=Doudom($E2;"a";COLONNES($A:A)) ramène 2 2 7 0 5
A+

 

[doudom]

Re : Macro pour extraire caractères d'une cellule

Bonjour David,

Tout d'abord, merci pour votre aide.

J'ai testé et j'ai le même résultat qu'avant, à savoir, qu'il n'exclut que les "a".

De plus la mise à jour ce fait uniquement lorsque j'enregistre est ce normal

Ci joint le fichier avec votre fonction

Doudom

 

[david84]

Re : Macro pour extraire caractères d'une cellule

Re
dans ce cas, une autre fonction basée sur une expression rationnelle à tester :

Function Doudom(chaine As String, Rang As Integer) As String
Dim oRegExp As Object, Matches As Object
Set oRegExp = CreateObject("vbscript.regexp")
If chaine = "" Then Exit Function
With oRegExp
    .Global = True
    .Pattern = "(\d|[A-Z])+"
    If .test(chaine) = True Then
        Set Matches = .Execute(chaine)
        If Rang - 1 < Matches.Count Then Doudom = Matches(Rang - 1)
    End If
Set oRegExp = Nothing: Set Matches = Nothing
End With
End Function

=Doudom($E2;COLONNES($A:A)) à tirer vers la droite et le bas.

De plus la mise à jour ce fait uniquement lorsque j'enregistre est ce normal

Dans les options Excel, passer le mode de calcul sur automatique.
A+

 

[doudom]

Re : Macro pour extraire caractères d'une cellule

Re,

Merci je test ça demain ( je dois m'absenter)et vous tiens au courant.

Bonne soirée

A+

 

[laurent950]

Re : Macro pour extraire caractères d'une cellule

Bonsoir le forum,

Ce code prend en compte que les valeurs numériques :
tous type de chaine de caractéres est un séparateur, puis extration dans une case.

Sub Macro1()

Dim F1 As Worksheet
Set F1 = Worksheets("Feuil1")

fin = F1.Range("E65536").End(xlUp).Row


Dim tab1 As Variant
tab1 = F1.Range(F1.Cells(2, 5), F1.Cells(fin, 5))

For i = 1 To UBound(tab1)
cpt = 1
x = Len(tab1(i, 1))
    For j = 1 To x
        If IsNumeric(Mid(tab1(i, 1), j, 1)) Then
            F1.Cells(1 + i, 5 + cpt) = Mid(tab1(i, 1), j, 1)
            cpt = cpt + 1
        End If
    Next j
cpt = Empty
Next i


End Sub

Laurent

 

[laurent950]

Re : Macro pour extraire caractères d'une cellule

Suite,

Les deux Macro dans le fichier excel au choix a adapter.

Choix des séparateurs en fonction d'une liste à compléter :

Nota : Conserve le faite du choix Minuscule ou Majuscule (pour les séparateurs)
Si les majuscules ou minuscules ne sont pas un choix de séparateurs
Placer en tout début de macro
Option Compare Text (enlever l'apostrophe devant le texte pour la prise en compte"

'Option Compare Text
Sub Macro2()

Dim test As Boolean
'MsgBox test    ' test = faux

Dim F1 As Worksheet
Set F1 = Worksheets("Feuil1")
 
fin = F1.Range("E65536").End(xlUp).Row
Dim tab1 As Variant
 tab1 = F1.Range(F1.Cells(2, 5), F1.Cells(fin, 5))

fin2 = F1.Range("A65536").End(xlUp).Row
Dim tab2 As Variant
tab2 = F1.Range(F1.Cells(2, 1), F1.Cells(fin2, 1))
 
For i = 1 To UBound(tab1)
 cpt = 1
 x = Len(tab1(i, 1))
     For j = 1 To x
            For k = 1 To UBound(tab2)
            'MsgBox Mid(tab1(i, 1), j, 1)
                If Mid(tab1(i, 1), j, 1) = tab2(k, 1) Then
                test = True
                End If
            Next k
        If test <> True Then
        F1.Cells(1 + i, 5 + cpt) = Mid(tab1(i, 1), j, 1)
        cpt = cpt + 1
        End If
        test = False
     Next j
 cpt = Empty
 Next i
End Sub