Macro pour cree des lignes dans une cellule ayant plusieurs donnees

[LOLO28]

BONJOUR .

J'AIMERAI FAIRE UNE MACRO QUI DANS LA COLONNE H ?I ET J CONTIENT PLUSIEURS DONNEES PAR CELLULE DE FAIRE AUTANT DE LIGNE QUE DE DONNEES DE CETTE CELLULE .

je Joins le fichiers . la feuil2 est le feuille ou je souhaite travailler.
la feuil3 est le résultat que j'aimerais obtenir sur la feuil2 à l'aide d'une macro
merci de votre aide

 

[mapomme]

Re : Macro pour cree des lignes dans une cellule ayant plusieurs donnees

Bonjour LOLO28,

BONJOUR .
J'AIMERAI FAIRE UNE MACRO QUI DANS LA COLONNE H ?I ET J CONTIENT PLUSIEURS DONNEES PAR CELLULE DE FAIRE AUTANT DE LIGNE QUE DE DONNEES DE CETTE CELLULE .

Inutile de CRIER, les minuscules suffisent amplement.

Un essai dans le fichier joint. Le code est dans module "Eclater":

Sub Ventiler()
Dim fin As Range, ici As Range
Dim finLig As Long, i As Long, j As Long, isplit As Long

Application.ScreenUpdating = False
With Sheets("Feuil2")
  'fin des lignes sources
  Set fin = .Cells(.Rows.Count, "a").End(xlUp)
  'cellule de la ligne d'écriture
  Set ici = fin.Offset(1, 0)
  'n° dernière lignes sources
  finLig = fin.Row
  'effacement lignes après données source
  .Range(ici, .Cells(.Rows.Count, "j")).Clear
  'boucle sur les lignes sources
  For i = 9 To finLig
    'nombre de destinations de la ligne à traiter
    isplit = 1 + UBound(Split(.Cells(i, "H"), Chr(10)))
    'écriture des 7 premières colonnes
    ici.Resize(, 7).Value = .Cells(i, "a").Resize(, 7).Value
    'écriture des colonnes H,I et J
    ici.Offset(, 7).Resize(isplit).Value = _
        Application.Transpose(Split(.Cells(i, "H"), Chr(10)))
    ici.Offset(, 8).Resize(isplit).Value = _
        Application.Transpose(Split(.Cells(i, "I"), Chr(10)))
    ici.Offset(, 9).Resize(isplit).Value = _
        Application.Transpose(Split(.Cells(i, "J"), Chr(10)))
    'fusion des colonnes A à G
    For j = 1 To 7
      With ici.Offset(, j - 1).Resize(isplit)
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .MergeCells = True
      End With
    Next j
    'Appliquer bordure aux lignes écrites
    ici.Resize(isplit, 10).Borders.LineStyle = xlContinuous
    'prochaine cellule où écrire
    Set ici = ici.Offset(1)
  Next i
  'effacer lignes sources
  .Range(.Range("A9"), .Cells(finLig, "j")).Delete xlShiftUp
End With

Application.ScreenUpdating = True
End Sub

 

[LOLO28]

Re : Macro pour cree des lignes dans une cellule ayant plusieurs donnees

merci pour la réponse,,exactement le résultat espéré.
MAIS,
lorsque je mets le même fichier du jour suivant avec le même format dans la cellule A8 puis "éclater" les cellules, le fichier nouveau s'insère bien mais il n'y a pas d' éclatement des cellules. De plus l'ancien fichier s'insère après le dernière cellule du nouveau fichier, alors que je n'en ai plus besoin.
Merci