Macro VBA Excel

J'ai besoin de l'aide des spécialistes macros VBA pour Excel.

En pièce jointe mon fichier.

J'explique.

En feuil1 de ce fichier, l'exemple d'une extraction qui m'arrive chaque jour et que je dois traiter.

Apparaissent des données sur des lignes.

Dans certaines cellules se trouvent des données uniques (exemple en A2 -

Identifiant avec 1 seul numéro) et dans certaines autres cellules des

données multiples (exemple en B2, 3 noms différents).

Je cherche une macro qui pourrait me donner le résultat que je souhaite et que je montre sur la feuil2.

Que les données multiples soient divisées en plusieurs lignes et que les données uniques du coup apparaissent sur chaque lignes.

Le pbroblème a peut être déjà été évoqué et réglé sur le forum.

Je vous prie de me pardonner si je n'ai pas su faire une recherche par les bons mots clés.

Je viens de trouver un code qui m'irait bien.
Le truc c'est qu'il marche sur la cellule dans laquelle je suis positionné.
Quelqu'un saurait l'adapter pour que chaque cellule d'une ligne soit testée(nombre de cellules varibale) puis toutes les lignes (nombre de lignes variable) ?
Merci

Le code :

Sub copiecolle()
Dim a As Integer, b As Integer, colonne As Integer
Dim rang As Long
colonne = 1
With ActiveCell
a = InStr(.Value, Chr(10))
If a = 0 Then
Sheets(2).Cells(1, 1) = .Value
Exit Sub
Else
Sheets(2).Cells(1, 1) = Left(.Value, a - 1)
End If
a = 0
Do
a = InStr(a + 1, .Value, Chr(10))
b = InStr(a + 1, .Value, Chr(10))
If b = 0 Then b = Len(.Value) + 1
colonne = colonne + 1
Sheets(2).Cells(1, colonne) = Mid(.Value, a + 1, b - a - 1)
Loop Until b = Len(.Value) + 1
End With
End Sub

En vous remerciant pour votre aide.

Bonjour Salykato et bienvenu, bonjour le forum,

Essaie comme ça :

Sub Macro1()
Dim O As Worksheet ' déclare la variable O (Onglet)
Dim TV As Variant ' déclare la variable TV (Tableau des Valeurs)
Dim I As Integer ' déclare la variable I (Incrément)
Dim NB As Byte ' déclare la variable NB (NomBre)
Dim J As Byte ' déclare la variable J (incrément)

Set O = Worksheets("Feuil1") ' définit l'onglet O
TV = O.Range("A1").CurrentRegion ' définit le tableau des valeurs TV
For I = UBound(TV, 1) To 2 Step -1 'boucle 1 : inversée de la dernière ligne à la ligne 2 en remontant
    NB = UBound(Split(TV(I, 2), Chr(10))) 'définit le nombre NB (nombre de fois qu'il y a un retour de charriot) dans la donnée ligne I colonne 2 de TV
    If NB > 0 Then 'condition : si NB st supérieure à zéro
        For J = 1 To NB ' boucle 2 : de 1 à NB
            O.Rows(I + 1).Insert ' insère une ligne en-dessous de la ligne I
            O.Cells(I + 1, "A").Value = TV(I, 1) ' renvoie dans la cellule de la ligne insérée en colonne A, la donnée ligne I colonne 1 de TV
            ' renvoie dans la cellule de la ligne insérée en colonne B, le nom après le NB-J+1 ème retour de charriot de la donnée ligne I colonne 2 de TV
            O.Cells(I + 1, "B").Value = Split(TV(I, 2), Chr(10))(NB - J + 1)
            ' renvoie dans la cellule de la ligne insérée en colonne C, la lettre après le NB-J+1 ème retour de charriot de la donnée ligne I colonne 3 de TV
            O.Cells(I + 1, "C").Value = Split(TV(I, 3), Chr(10))(NB - J + 1)
            O.Cells(I + 1, "D").Value = TV(I, 4) ' renvoie dans la cellule de la ligne insérée en colonne C, le code de lq donnée ligne I colonne 4 de TV
        Next J ' prochaine valeur de la boucle 2
        O.Cells(I, "B").Value = Split(TV(I, 2), Chr(10))(0) ' modifie dans la cellule de la ligne I en colonne B, uniquement le premier nom
        O.Cells(I, "C").Value = Split(TV(I, 3), Chr(10))(0) ' modifie dans la cellule de la ligne I en colonne B, uniquement la première lettre
    End If 'fin de la condition
Next I ' prochaine ligne de la boucle 1
End Sub

Bonjour Thauthem,

Grillé ! Tant pis j'y vais de ma version... J'ai le sentiments que s'il y a beaucoup de ligne, ça sera beaucoup plus rapide !

La même en couleur et sans blabla :

Sub Galopin()
Dim a, b(), rng As Range, I%, Arr1, Arr2, irC%, k
ReDim b(3, 1)
Set rng = [A1].CurrentRegion
With rng
Set rng = .Offset(1).Resize(.Rows.Count - 1)
End With
a = rng.Value
For I = 1 To UBound(a)
Arr1 = Split(a(I, 2), Chr(10))
Arr2 = Split(a(I, 3), Chr(10))
For k = 0 To UBound(Arr1)
b(0, irC) = a(I, 1)
b(1, irC) = Arr1(k)
b(2, irC) = Arr2(k)
b(3, irC) = a(I, 4)
irC = irC + 1
ReDim Preserve b(3, UBound(b, 2) + 1)
Next
Next
Feuil2.[A2].Resize(UBound(b, 2), 4) = WorksheetFunction.Transpose(b)
End Sub

A+

Bonjor,

Vous êtes top !

Merci pour votre aide précieuse.

Seul bémol, certaines cellules peuvent avoir plusieurs lignes ou une seule (colonne B par exemple).

Du coup, ça plante.

Peut on ajouter une condition "ou" ?

Par avance merci.

Tu veux dire que la colonne B peux n'avoir qu'une ligne et la colonne C plusieurs ?

ou plusieurs dans B et une seule dans C ?

Toutes les colonnes auront t-elle au moins une cellule non vide ?

La colonne 1 et 4 peuvent elles avoir des anomalies ?

Avec la solution précédente, je n'ai pas d'erreur s'il n'y a qu'une ligne partout.

Il faut un exemple qui montre tous les cas particuliers et la manière de les traiter !

A+