VBA Partager les données d'une cellule en 2
Bonjour,
J'ai une plage de cellules qui contiennent toutes le même type de données :
A : Villes (N° Minéralogique)
Je voudrais obtenir 2 colonnes
B: Villes,
c'est-à-dire
=GAUCHE(A1;NBCAR(A1)-4)et
C: N° Minéralogique [sans les parenthèses]
c'est-à-dire
=GAUCHE(DROITE(A1;3);2)Mais je ne sais pas coder ces deux exemples en VBA.
Merci de votre aide.
Bonjour
Essaye :
Sub Convertir()
Application.ScreenUpdating = False
Dim c As Range
For Each c In Range("A2:A" & Range("A65536").End(xlUp).Row)
Cells(c.Row, 2) = Left(c, Len(c) - 4)
Cells(c.Row, 3) = Left(Right(c, 3), 2)
Next c
End SubAmicalement
Nad
Bonsoir,
Merci de cette proposition qui fonctionne mais qui ne me satisfait pas entièrement ; mais c'est de ma faute, je me suis mal expliqué.
Je suis déjà dans une boucle et j'ai du mal à intégrer celle proposée.
Ci-dessous mon code commenté. Les lignes à modifiées sont celles des lieux et des dépt comme indiqué.
Sub Nim_Migra()
Dim WsOrig As Worksheet
Dim WsResu As Worksheet
Dim J As Long
Dim Ligne As Long
laDateExport$ = Format(Date, "mm/dd/yyyy")
France$ = "France"
vide$ = " "
Set WsOrig = Sheets("NIMEGUE3")
Set WsResu = Sheets("Migranet")
Set WsRef = Sheets("Explications")
Ligne = 1
For J = 2 To WsOrig.Range("A" & Rows.Count).End(xlUp).Row
WsOrig.Range("K" & J).Copy WsResu.Range("B" & Ligne) ' NOM M1
WsResu.Range("C" & Ligne).FormulaR1C1 = WsOrig.Range("L" & J) & ", " & WsOrig.Range("O" & J) & " ans, " & WsOrig.Range("Q" & J) ' Prénom M1, âge, profession
WsOrig.Range("G" & J).Copy WsResu.Range("D" & Ligne) ' Date X
WsOrig.Range("N" & J).Copy WsResu.Range("E" & Ligne) ' Date N M1
WsOrig.Range("AF" & J).Copy WsResu.Range("F" & Ligne) ' Date N M2
WsOrig.Range("C" & J).Copy WsResu.Range("G" & Ligne) ' Lieu X
WsOrig.Range("M" & J).Copy WsResu.Range("H" & Ligne) ' Lieu N M1 (à modifier GAUCHE(NBCAR(Lieu)-4)
WsOrig.Range("AE" & J).Copy WsResu.Range("I" & Ligne) ' Lieu N M2 (à modifier GAUCHE(NBCAR(Lieu)-4)
WsOrig.Range("D" & J).Copy WsResu.Range("J" & Ligne) ' Dept X
WsOrig.Range("M" & J).Copy WsResu.Range("K" & Ligne) ' Dept N M1 (à calculer GAUCHE(DROITE(A1;3);2)
WsOrig.Range("AE" & J).Copy WsResu.Range("L" & Ligne) ' Dept N M2 (à calculer GAUCHE(DROITE(A1;3);2)
WsOrig.Range("AC" & J).Copy WsResu.Range("M" & Ligne) ' Nom M2
WsResu.Range("N" & Ligne).FormulaR1C1 = WsOrig.Range("AD" & J) & ", " & WsOrig.Range("AG" & J) & " ans, " & WsOrig.Range("AI" & J) ' Prénom M2, âge, profession
WsOrig.Range("U" & J).Copy WsResu.Range("O" & Ligne) ' Nom Père M1
WsResu.Range("P" & Ligne).FormulaR1C1 = WsOrig.Range("V" & J) & ", " & WsOrig.Range("X" & J) & ", " & WsOrig.Range("W" & J) ' Prénom Père M1, profession, commentaire
WsOrig.Range("Y" & J).Copy WsResu.Range("Q" & Ligne) ' Nom Mère M1
WsResu.Range("R" & Ligne).FormulaR1C1 = WsOrig.Range("Z" & J) & ", " & WsOrig.Range("AB" & J) & ", " & WsOrig.Range("AA" & J) ' Prénom Mère M1, profession, commentaire
WsOrig.Range("AM" & J).Copy WsResu.Range("S" & Ligne) ' Nom Père M2
WsResu.Range("T" & Ligne).FormulaR1C1 = WsOrig.Range("AN" & J) & ", " & WsOrig.Range("AP" & J) & ", " & WsOrig.Range("AO" & J) ' Prénom Père M2, profession, commentaire
WsOrig.Range("AQ" & J).Copy WsResu.Range("U" & Ligne) ' Nom Mère M2
WsResu.Range("V" & Ligne).FormulaR1C1 = WsOrig.Range("AR" & J) & ", " & WsOrig.Range("AT" & J) & ", " & WsOrig.Range("AS" & J) ' Prénom Mère M2, profession, commentaire
WsResu.Range("W" & Ligne).FormulaR1C1 = WsOrig.Range("AU" & J) & " " & WsOrig.Range("AV" & J) & " " & WsOrig.Range("AW" & J) ' T1
WsResu.Range("X" & Ligne).FormulaR1C1 = WsOrig.Range("AX" & J) & " " & WsOrig.Range("AY" & J) & " " & WsOrig.Range("AZ" & J) ' T2
WsResu.Range("Y" & Ligne).FormulaR1C1 = WsOrig.Range("BA" & J) & " " & WsOrig.Range("BB" & J) & " " & WsOrig.Range("BC" & J) ' T3
WsResu.Range("Z" & Ligne).FormulaR1C1 = WsOrig.Range("BD" & J) & " " & WsOrig.Range("BE" & J) & " " & WsOrig.Range("BF" & J) ' T4
WsResu.Range("AA" & Ligne).FormulaR1C1 = WsOrig.Range("BG" & J) & ", Epx: " & WsOrig.Range("P" & J) & ", Epse: " & WsOrig.Range("AH" & J) ' Notes, sources, com M1, com M2
WsResu.Range("AB" & Ligne).FormulaR1C1 = WsRef.Range("C" & 21) & " " & WsRef.Range("C" & 22) ' Nom Prénom Déposant
WsRef.Range("C" & 23).Copy WsResu.Range("AC" & Ligne) ' Mail Déposant
WsRef.Range("C" & 24).Copy WsResu.Range("AD" & Ligne) ' Site Déposant
WsResu.Range("AE" & Ligne).Value = vide$ ' Case vide
WsResu.Range("AF" & Ligne).Value = France$ ' France
WsResu.Range("AG" & Ligne).Value = laDateExport$ ' Date
Ligne = Ligne + 1
Next J
End SubRe
Essaye en remplaçant les lignes concernées par
WsResu.Range("H" & Ligne) = Left(WsOrig.Range("M" & J), Len(WsOrig.Range("M" & J)) - 4)
WsResu.Range("I" & Ligne) = Left(WsOrig.Range("AE" & J), Len(WsOrig.Range("M" & J)) - 4)
WsResu.Range("K" & Ligne) = Left(Right(WsOrig.Range("M" & J), 3), 2)
WsResu.Range("L" & Ligne) = Left(Right(WsOrig.Range("AE" & J), 3), 2)Nad
Re,
L'idée est bonne mais ça plante sans explication
Message d'erreur :
Erreur d'exécution '5'
Argument ou appel de procédure incorrect
Il semble qu'il faille qch comme
WsResu.Range("H" & Ligne).FormulaR1C1 = Left(WsOrig.Range("M" & J), Len(WsOrig.Range("M" & J)) - 4)ou
WsResu.Range("H" & Ligne).Value = Left(WsOrig.Range("M" & J), Len(WsOrig.Range("M" & J)) - 4)Mais ni l'un ni l'autre ne fonctionnent.
Re
Ça plante comment ? Quel est le message d'erreur ?
Mon fichier test :
Nad
Re
Après test, j'ai réussi à faire planter le code.
Exemple : il y a une donnée en A(derligne) mais pas de ville en AE(derligne)
Pour y remédier, ajoute On Error Resume Next dans ta procédure
.......
For J = 2 To WsOrig.Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next
..........Nad
Très bizarre,
Le passage de la 1° ligne se déroule à peu près correctement
Il a fallu que je modifie
WsResu.Range("I" & Ligne) = Left(WsOrig.Range("AE" & J), Len(WsOrig.Range("M" & J)) - [color=#FF0000]4[/color])en
WsResu.Range("I" & Ligne) = Left(WsOrig.Range("AE" & J), Len(WsOrig.Range("M" & J)) - [color=#0000FF]5[/color])sinon ça laissait la (
mais ça bugge au passage de la 2° ligne sur :
WsResu.Range("H" & Ligne) = Left(WsOrig.Range("M" & J), Len(WsOrig.Range("M" & J)) - 4)Erreur '5' comme tout à l'heure
As-tu testé la procédure indiquée avant ton dernier message ?
Nad
Désolé de tout ce dérangement.
En fait mon fichier d'origine n'était pas cohérent.
Les ligne données fonctionnent bien
WsResu.Range("H" & Ligne) = Left(WsOrig.Range("M" & J), Len(WsOrig.Range("M" & J)) - 5)
WsResu.Range("I" & Ligne) = Left(WsOrig.Range("AE" & J), Len(WsOrig.Range("M" & J)) - 5)
WsResu.Range("K" & Ligne) = Left(Right(WsOrig.Range("M" & J), 3), 2)
WsResu.Range("L" & Ligne) = Left(Right(WsOrig.Range("AE" & J), 3), 2)Merci bcp
Re,
Pour éviter le bug si la case sur laquelle s'opère le calcul est non renseignée (supprimer des signes dans une case vide...), j'ai ajouté le contrôle suivant :
If WsOrig.Range("M" & J).Value <> "" Then WsResu.Range("H" & Ligne) = Left(WsOrig.Range("M" & J), Len(WsOrig.Range("M" & J)) - 4) ' Lieu N M1
If WsOrig.Range("AE" & J).Value <> "" Then WsResu.Range("I" & Ligne) = Left(WsOrig.Range("AE" & J), Len(WsOrig.Range("M" & J)) - 4) ' Lieu N M2 Re,
Autre problème.
Certaines villes sont des mots composés séparés par des trait d'union "-".
Comment forcer la fonction
len(Nom-de-Ville) pour qu'elle ne s'arrête pas au 1° trait d'union
len(Nommais prenne bien en compte l'ensemble de la chaîne ?
Sinon
Left("Neuchatel-sur-Rivière (64)", Len("Neuchatel-sur-Rivière (64)") - 4)renvoie la même valeur que si la ville était Neuchatel
Left("Neuchatel (64)", Len("Neuchatel (64)") - 4)C'est même pire
Left("Neuchatel-sur-Rivière (64)", Len("Neuchatel-sur-Rivière (64)") - 4)renvoie
Left("Neuchatel", Len("Neuchatel") - 4)C'est-à-dire Neuch
Nad a écrit :Re
Après test, j'ai réussi à faire planter le code.
Exemple : il y a une donnée en A(derligne) mais pas de ville en AE(derligne)
Pour y remédier, ajoute On Error Resume Next dans ta procédure
....... For J = 2 To WsOrig.Range("A" & Rows.Count).End(xlUp).Row On Error Resume Next ..........Nad
Je n'avais pas vu ce message.
Merci pour cette solution qui simplifie.