[VBA] Modifications chaines de caractères

Le 18/04/2020 à 16:22

Bonjour,

Pour les modifications assez basique des chaines de caractères, j'arrive toujours à me débrouiller avec ce que je trouve ici et là.

Mais dans le cas présent, je ne sais pas bien comment réorganiser les éléments qui se trouvent dans mes cellules.

Chaque donnée ce compose d'une nom de genre et d'espèce ; d'un nom d'auteur, d'une précision "var." ou "subsp." suivi du nom associé.

J'aimerais que le nom d'auteur se retrouve systématiquement à la fin.

Ce que j'ai fait pour le moment :

For a = 2 To lrbf
z = "": y = "": x = ""
'If .Cells(a, cib) Like "*Hallier f.*" Then .Cells(a, cib) = Replace(.Cells(a, cib), "f.", "fr.")
    If .Cells(a, cib) Like "*subsp.*" Then
    z = Left(.Cells(a, cib), InStr(.Cells(a, cib), "subsp.") - 1)
    y = Left(Mid(.Cells(a, cib), InStr(1, .Cells(a, cib), "subsp.")), InStr(Mid(.Cells(a, cib), InStr(1, .Cells(a, cib), " ") + 1), " ") - 1)
    .Cells(a, cib1) = Split(Mid(.Cells(a, cib), InStr(1, .Cells(a, cib), "subsp.") + 7), " ", 2)
    x = .Cells(a, cib1)
    .Cells(a, cib1) = z & y & x

    ElseIf .Cells(a, cib) Like "*var.*" Then
    z = Left(.Cells(a, cib), InStr(.Cells(a, cib), "var.") - 1)
    y = Left(Mid(.Cells(a, cib), InStr(1, .Cells(a, cib), "var. ")), InStr(Mid(.Cells(a, cib), InStr(1, .Cells(a, cib), " ") - 1), " ") + 2)
    .Cells(a, cib1) = Split(Mid(.Cells(a, cib), InStr(1, .Cells(a, cib), "var.") + 5), " ", 2)
    x = .Cells(a, cib1)
    .Cells(a, cib1) = z & y & x

    ElseIf .Cells(a, cib) Like "* f.*" Then
    On Error Resume Next
        If Not .Cells(a, cib) Like "*f.,*" Then
        If Not .Cells(a, cib) Like "*f.)*" Then
            z = Left(.Cells(a, cib), InStr(.Cells(a, cib), "f.") - 1)
            y = Left(Mid(.Cells(a, cib), InStr(1, .Cells(a, cib), "f. ")), InStr(Mid(.Cells(a, cib), InStr(1, .Cells(a, cib), " ") - 1), " ") + 1)
            .Cells(a, cib1) = Split(Mid(.Cells(a, cib), InStr(1, .Cells(a, cib), "f.") + 3), " ", 2)
            x = .Cells(a, cib1)
            .Cells(a, cib1) = z & y & x
        End If
        End If

    Else
    z = Left(.Cells(a, cib), InStr(.Cells(a, cib), " ") - 1)
    y = Left(Mid(.Cells(a, cib), InStr(1, .Cells(a, cib), " ") + 1), InStr(Mid(.Cells(a, cib), InStr(1, .Cells(a, cib), " ") + 1), " ") - 1)
    .Cells(a, cib1) = z & " " & y
    End If

z = "": y = "": x = ""
    If .Cells(a, cib) Like "*subsp.*" Then
        .Cells(a, cib2) = Mid(.Cells(a, cib), InStr(.Cells(a, cib), " ") + 1)
        .Cells(a, cib2) = Mid(.Cells(a, cib2), InStr(.Cells(a, cib2), " ") + 1)
        .Cells(a, cib2) = Mid(.Cells(a, cib2), InStr(.Cells(a, cib2), " ") + 1)
        .Cells(a, cib2) = Mid(.Cells(a, cib2), InStr(.Cells(a, cib2), " ") + 1)
    ElseIf .Cells(a, cib) Like "*var.*" Then
        .Cells(a, cib2) = Mid(.Cells(a, cib), InStr(.Cells(a, cib), " ") + 1)
        .Cells(a, cib2) = Mid(.Cells(a, cib2), InStr(.Cells(a, cib2), " ") + 1)
        .Cells(a, cib2) = Mid(.Cells(a, cib2), InStr(.Cells(a, cib2), " ") + 1)
        .Cells(a, cib2) = Mid(.Cells(a, cib2), InStr(.Cells(a, cib2), " ") + 1)
    ElseIf .Cells(a, cib) Like "* f.*" Then
        .Cells(a, cib2) = Mid(.Cells(a, cib), InStr(.Cells(a, cib), " ") + 1)
        .Cells(a, cib2) = Mid(.Cells(a, cib2), InStr(.Cells(a, cib2), " ") + 1)
        .Cells(a, cib2) = Mid(.Cells(a, cib2), InStr(.Cells(a, cib2), " ") + 1)
        .Cells(a, cib2) = Mid(.Cells(a, cib2), InStr(.Cells(a, cib2), " ") + 1)
    Else
        .Cells(a, cib2) = Mid(.Cells(a, cib), InStr(.Cells(a, cib), " ") + 1)
        .Cells(a, cib2) = Mid(.Cells(a, cib2), InStr(.Cells(a, cib2), " ") + 1)

    End If
Next a
End With

Je joins un document à ce post, pour mieux illustrer le résultat que j'essaie d'obtenir.

J'essaie de faire ça en VBA pour que cette base de données puisse être mise à jour à chaque fois qu'elle est modifiée par le producteur de cette BDD.

A plus tard

9test-chaines-caracteres.xlsx (8.72 Ko)
Le 18/04/2020 à 17:58

bonjour,

bonsoir,

une proposition sur base des données que tu as mises, si 4ème mot est var. ou subsp. prendre le mot précédent et le mettre à la fin, sinon prendre la chaine telle quelle.

Sub aargh()
    For i = 2 To 11
        tBase = Cells(i, 1)
        t = Split(tBase, " ")
        Select Case t(3)
            Case "var.", "subsp."
                r = Replace(tbase,t(2),"") & " " & t(2)
            Case Else
                r = tBase
        End Select
        Cells(i, 3) = r
    Next i
End Sub
Le 18/04/2020 à 19:27

Bonsoir,

Encore un énorme merci pour votre aide ! D'une part je découvre des solutions géniales pour réaliser différentes tâches mais en plus ça me permet de réécrire des codes bancals que j'utilisais et qui fonctionnent, eux aussi, à la perfection maintenant !

Je vais voir si je peux combiner votre solution, avec la création d'un tableau virtuel pour que le traitement soit plus rapide (ici il se fait en quelques secondes sur 10 000 lignes).

Code que j'ai pu mettre au point sur la base de ce que vous avez proposé, pour séparer des données en fonction de la position de l'espace dans la chaine de caractères.

Sub maj_bsfl_1b() ' Merci h2so4 (Excel-pratique)
Dim lrbf&, i&, nsm As Byte, lans As Byte, lbns As Byte, r$, s$

With Sheets("baseflor_maj_2020_04_18")
lrbf = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
nsm = .Range("1:1").Find("NOM_SCIENTIFIQUE_MAJ", LookIn:=xlValues, Lookat:=xlWhole).Column
lbns = .Range("1:1").Find("LB_NOM_SCIENTIFIQUE", LookIn:=xlValues, Lookat:=xlWhole).Column
lans = .Range("1:1").Find("LB_AUTEUR_NOM_SCIENTIFIQUE", LookIn:=xlValues, Lookat:=xlWhole).Column

    For i = 2 To lrbf
        tBase = Cells(i, nsm)
        t = Split(tBase, " ")
        Select Case t(2)
            Case "var.", "subsp."
                r = "": s = ""
                For j = 0 To UBound(t)
                    If j < 4 Then r = r & t(j) & " "
                    If j >= 4 Then s = s & t(j) & " "
                Next j
            Case Else
                r = "": s = ""
                For j = 0 To UBound(t)
                    If j < 2 Then r = r & t(j) & " "
                    If j >= 2 Then s = s & t(j) & " "
                Next j
        End Select
        .Cells(i, lbns) = r
        .Cells(i, lans) = s
    Next i
End With
End Sub

Ici je sépare des noms de genre/espèce ou genre espèce sous-espèce (/variété) de leur nom d'auteur.

Bonne fin de soirée !

Rechercher des sujets similaires à "vba modifications chaines caracteres"