[vba] Extraction plusieurs chaînes caracteres

Payet -  
michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   -
Bonjour,

je dispose d'un fichier excel dans lequel chaque cellule contient "'NOM : floflo

PRENOM : flooooooooo

DATE DE NAISSANCE : 24/05/1986

EMAIL : coaaalo@live.fr

NEWSLETTER :

ADRESSE : 3 rue de la aaaaaaa

CP : 13000

VILLE : martigues"

.

J'ai environ 22 000 celulles (A1,B1,C1..). Je voudrais extraire chaque élement de coordonnées(nom,prénoms, email...), de chaque cellule, afin d'arriver à un tableau avec une colonne nom, prénom, etc...

C'est mon 1er code VBA, alors c'est pas beau à voir!

J'ai supprimé chaque instance du mot "NOM", du mot "PRENOM" etc... Afin d'arriver avec des celulles qui contiennent uniquement ce que je veux récupérer ("floflo" "floooooo" etc) séparés par des ":" et ainsi utiliser la fonction split avec comme élement séparateur ":".

Je n'ai pas trouvé de sujet comparable avec autant de données à récupérer. J'ai également vu qu'on pouvait le faire avec des formules mais n'ai pas réussi à l'adapter à mon cas.

En espérant votre aide,
Cordialement. 

Dim LaDerLigne As Integer

Sub move_coordonnes()

' Dernière ligne de la plage
LaDerLigne = Range("A65536").End(xlUp).Row

Range("A1").Activate

    ' Sortie de boucle lorsque la ligne active est la dernière ligne
    Do Until ActiveCell.Row = LaDerLigne
    
        'active la cellule de la ligne suivante / même colonne
        ActiveCell.Offset(1, 0).Activate
        
        'création variable qui contiendra la chaîne de caractère à splittée
        Dim mavalue()
        asplitter = ActiveCell().Value
        
        Dim monTab() As String
            Dim i As Integer
        
        'extrait toutes les chaînes de caractère séparées par un : et les stocke dans monTab
        monTab = Split("asplitter", ":")
        
   
    
          'boucle sur le tableau pour visualiser le résultat
            For i = 0 To UBound(monTab)
                'replace le nom dans la 1 ére cellule à droite
                ActiveCell.Offset(0, 1).Value = monTab(0)
                ' replace le prenom dans la 2 éme cellule à droite etc...
                ActiveCell.Offset(0, 2).Value = monTab(1)
                ActiveCell.Offset(0, 3).Value = monTab(2)
                ActiveCell.Offset(0, 4).Value = monTab(3)
                ActiveCell.Offset(0, 5).Value = monTab(4)
                ActiveCell.Offset(0, 6).Value = monTab(5)
                ActiveCell.Offset(0, 7).Value = monTab(6)
                ActiveCell.Offset(0, 8).Value = monTab(7)
            Next i
    
    
    
    'boucle de plage
    Loop

End Sub

2 réponses

  1.
    michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
     
    Bonjour,

    Si j'ai bien compris (c'est lundi) tu as actuellement dans UNE cellule des données séparées par des ":" et ce sur 20000 lignes environ
    Tu voudrais mettre une donnée par cellule

    Si oui, sans VBA, tu peux utiliser "données-convertir"

    ou utiliser l'enregistreur de macro avec ce "données -convertir" sur quelques lignes si tu tiens à une macro
    tu élagues ce qui n'est pas nécessaire (voir l'aide en ligne) et tu utilises laderligne pour délimiter la zone de travail sans avoir à dérouler sur 20000 lignes
    0
  2. Payet
     
    Ca fonctionne merci bien.
    Mais si quelqu'un pouvait me dire ce qui ne va pas dans mon code, j'aimerais beaucoup y arriver par du code.
    Merci.
    0
    1. michel_m Messages postés 18903 Date d'inscription   Statut Contributeur Dernière intervention   3 320
       
      Bonjour,

      Dim monTab() As String: t'es sûr ? (date de naissance, peut-^tre CP)

      par prudence déclare sans préciser 
      dim montab



      Tu ne commences pas par le + facile en VBA surtout avec de grands tableaux... :-)
      règle de base en VBA: éviter au maximum de boucler avec des activecell, select-selection et autre copy-paste

      proposition 
      Option Explicit
Sub separer()
'sur 22000 lignes, il est nécessaire de 'sortir d'XL et de travailler en RAM par un array
'gain de temps >2000 fois par apport à activation cellules
Dim derlig As Long, lig As Long, col As Byte
Dim separe, T_out

derlig = Range("A65536").End(xlUp).Row
ReDim T_out(derlig - 1, 6) ' un array commence à 0 et non 1
'collecte les cellules les séparent par ";" et les mémorise en RAM dans une variable- tableau
For lig = 1 To derlig
    separe = Split(Cells(lig, 1), ":")
        For col = 0 To UBound(separe)
            T_out(lig - 1, col) = separe(col)
        Next
Next
'fige le défilement de l'écran
Application.ScreenUpdating = False
' mis en feuille 2 pour essais
Sheets(2).Range("A2:G" & derlig) = T_out

End Sub


      mais le + simple serait d'utiliser l'enregistreur de macro avec données convertir
      et d'ajouter 
       With Range("A1").CurrentRegion
        .TextToColumns Destinati...
         ....
end with
      0

Discussions similaires

Décryptage de chaînes précédées de '$'.
Cubde -
Rachid -

5 réponses
DECRYPTAGE DES CHAINES CRYPTES
A +++++++ -
madmyke -

2 réponses
décryptage de chaines payantes par satellite
260358 -
Aranud87 -

3 réponses