Création de X lignes par rapport à une cellule [résolu]

[oxychene]

Bonsoir à tous,

je souhaiterais savoir si il est possible, et si oui comment.

J'ai en colonne CT des valeur tels que 5,9,1... mais tous inférieur à 20.
J'ai besoin de créer autant de lignes que la valeur du nombre.

Par exemple ligne 10 valeur 5,00 lignes à créer à la suite
ligne 11 valeur 4,00 lignes à créer à la suite
ligne 12 valeur 3,00 lignes à créer à la suite
ligne 13 valeur 4,00 lignes à créer à la suite
.... et ceux sur environs 5000 lignes
Bien sur vous allez me dire que la ligne 11 avant création de nouvelle lignes deviendra la ligne 16 à la suite de création des ligne de la ligne 10 (10+5=15 CT11=CT16). Mais cela ne n’importe peu.

En fait c'est parce que mon tableau d'origine fonctionne avec des entrées par colonne.

Je doit changer de logiciel et ce dernier fonctionne par ligne/colonne.

Si vous souhaitez avoir un fichier cela peu être possible mais il est très lourd.

D'avance merci et bon appétit à ceux qui passe à table.

CDT, Oxychene

 

[oxychene]

Re : Création de X lignes par rapport à une cellule

3 minutes 40 pour votre dernier fichier.

Je songe toujours comment faire la dernière opération,

Pour moi oui ça sera la fin de soirée.

Je regarde demain matin de bonne heure si un nouveau message m'attend pour vous répondre au plus vite, et il parait que la nuit portE conseilS.

Bonne fin de soirée à vous aussi

 

[job75]

Re : Création de X lignes par rapport à une cellule

Re,

On ne pouvait pas deviner sans l'exemple de la ligne 18...

Document Cjoint

Sub InsereLignes()
Dim duree#, deb As Range, ncol%, derlig&, P As Range, rc&, t, tref, rest(), i&, n&, j%, n1
duree = Timer
Set deb = [A9:BM9] '1ère ligne du tableau
ncol = deb.Columns.Count 'nombre de colonnes du tableau
derlig = Cells(Rows.Count, deb.Column).End(xlUp).Row
Set P = deb.Resize(derlig - deb.Row + 1)
rc = P.Rows.Count
t = P.FormulaR1C1
tref = P.Columns(ncol).Value 'colonne de référence
'---tableau des résultats---
ReDim rest(1 To rc + Application.Sum(tref), 1 To ncol)
For i = 1 To rc
  n = n + 1
  For j = 1 To ncol
    rest(n, j) = t(i, j)
  Next
  n1 = 0
  For j = 40 To 64 'transfert des colonnes AN à BL...
    If t(i, j) = "" Then Exit For
    If LCase(t(i, j - 1)) Like "mo?taux*" Then
      rest(n + n1, 36) = t(i, j) '...en colonne AJ
    Else
      n1 = n1 + 1
      rest(n + n1, 2) = t(i, j) '...en colonne B
    End If
  Next
  n = n + tref(i, 1)
Next
Application.ScreenUpdating = False
Application.EnableEvents = False ' si macros évènementielles
Application.Calculation = xlCalculationManual 'si formules volatiles dans le classeur
'---effacement du tableau---
P = ""
'---insertion réelle de lignes---
For i = rc To 1 Step -1
  P(i + 1, 1).Resize(tref(i, 1)).EntireRow.Insert
  Application.StatusBar = "Réalisé " & Int(100 * (rc - i + 1) / rc) & " %" _
    & " - Lignes restantes " & i - 1
Next
'---restitution des formules et valeurs---
deb.Resize(n, ncol) = rest
[AN:BL].Clear 'facultatif, effacement de la zone transférée
Cells.WrapText = False 'évite les renvois à la ligne
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "Durée " & Format(Timer - duree, "0.00 \s")
End Sub

Bonne nuit.

 

[oxychene]

Re : Création de X lignes par rapport à une cellule

Bon je ne cessais de tourner dans mon lit avant de me relever à causse de ce vent...

J'ai vu votre message je suis sur le fichier depuis la macro à mis 3m40 et 3m29.

MAIS j'ai des problèmes de remplissage de cellules. Je suis donc en train de les rechercher toutes pour continuer.

Sinon au premier abord sans ce problème de cellule le travail réalisé par votre macro, semble plus que correct.

Je continue jusqu’à tomber dans le sommeil. Puis je finirais surement demain soir vu que le PC plante.

Mais je reviens vers vous très vite et normalement cela sera pour partager le fichier et mettre en résolu.

Encore merci pour votre grande aide job75

Cordialement
Oxychene

 

[job75]

Re : Création de X lignes par rapport à une cellule

Bonjour oxychene, le forum,

Puisqu'on étudie les colonnes AN à BL, les nombres en colonne BM sont inutiles et sources d'erreurs.

Document Cjoint

Sub InsereLignes()
Dim duree#, deb As Range, ncol%, derlig&, P As Range, rc&, t, tref%(), rest(), i&, n&, j%, n1%
duree = Timer
Set deb = [A9:BL9] '1ère ligne du tableau
ncol = deb.Columns.Count 'nombre de colonnes du tableau
derlig = Cells(Rows.Count, deb.Column).End(xlUp).Row
If derlig < deb.Row Then Exit Sub
Set P = deb.Resize(derlig - deb.Row + 1)
rc = P.Rows.Count
t = P.FormulaR1C1
ReDim tref(1 To UBound(t), 1 To 2) 'au moins 2 éléments
'---tableau des résultats---
ReDim rest(1 To rc + Application.CountA(Range(P.Columns(40), P.Columns(ncol))), 1 To ncol)
For i = 1 To rc
  n = n + 1
  For j = 1 To ncol
    rest(n, j) = t(i, j)
  Next
  n1 = 0
  For j = 40 To ncol 'transfert des colonnes AN à BL...
    If t(i, j) = "" Then Exit For
    If LCase(t(i, j - 1)) Like "mo?taux*" Then
      rest(n + n1, 36) = t(i, j) '...en colonne AJ
    Else
      n1 = n1 + 1
      rest(n + n1, 2) = t(i, j) '...en colonne B
    End If
  Next
  tref(i, 1) = n1 + 1
  n = n + tref(i, 1)
Next
Application.ScreenUpdating = False
Application.EnableEvents = False ' si macros évènementielles
Application.Calculation = xlCalculationManual 'si formules volatiles dans le classeur
'---effacement du tableau---
P = ""
'---insertion réelle de lignes---
For i = rc To 1 Step -1
  P(i + 1, 1).Resize(tref(i, 1)).EntireRow.Insert
  Application.StatusBar = "Réalisé " & Int(100 * (rc - i + 1) / rc) & " %" _
    & " - Lignes restantes " & i - 1
Next
'---restitution des formules et valeurs---
deb.Resize(n, ncol) = rest
[AN:BL].Clear 'facultatif, effacement de la zone transférée
Cells.WrapText = False 'évite les renvois à la ligne
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
duree = Timer - duree
MsgBox "Durée " & Int((duree) / 60) & " mn " & Round(duree - 60 * Int((duree) / 60)) & " s"
End Sub

Edit : j'avais modifié le chrono d'une manière erronée.

Bonne journée.

 

[oxychene]

Re : Création de X lignes par rapport à une cellule

Bonjour a tous a job 75,

Non il s'agissait vraiment de certaines cellules vide entre deux cellules d'articles. J'ai fini tôt ce matin le fichier. Je vais l'epurer pour le partager au plus vite.

Cordialement

 

[job75]

Re : Création de X lignes par rapport à une cellule

Re,

Non il s'agissait vraiment de certaines cellules vide entre deux cellules d'articles.

Dès le moment où la colonne BM a été supprimée il est facile de supprimer ces cellules vides.

Il suffit de lancer cette macro :

Sub Epure()
Dim duree#, deb As Range, ncol%, derlig&, P As Range, i&, j%, n&
duree = Timer
Set deb = [A9:BL9] '1ère ligne à traiter
ncol = deb.Columns.Count 'nombre de colonnes du tableau
derlig = Cells(Rows.Count, deb.Column).End(xlUp).Row
If derlig < deb.Row Then Exit Sub
Set P = deb.Resize(derlig - deb.Row + 1)
Application.ScreenUpdating = False
Application.EnableEvents = False ' si macros évènementielles
Application.Calculation = xlCalculationManual 'si formules volatiles dans le classeur
For i = 1 To P.Rows.Count
  For j = ncol - 1 To 40 Step -1 'de BK à AN
    If P(i, j) = "" And P(i, j + 1) <> "" Then P(i, j).Delete xlToLeft: n = n + 1
Next j, i
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "Durée " & Round(Timer - duree) & " s" _
  & vbLf & vbLf & n & " cellules vides supprimées"
End Sub

Résultat sur le dernier fichier joint : 343 cellules vides supprimées en 36 secondes.

A+

 

[oxychene]

Re : Création de X lignes par rapport à une cellule

Bonsoir à tous, à job75,

Je viens de ressayer votre second code.

Comment dire que par la preuve la connaissance apporte le bien être. Votre macro qui met 8 secondes à faire ce que j'ai fait en cinq heures cette nuit avec la lenteur de l’ordinateur puisque je n'ai pas su m'y prendre.

Enfin il ne faut pas oublier qu'il y à votre temps de réflexion et d'écriture du code.

Cela ne fait qu'aiguiser ma curiosité, pour vous quel est le niveau de difficulté pour ce fil de discussion? Pour le post 34 combien de temps cela peux vous prendre à réfléchir et à rédiger???

Le résultat que j'obtient est le même que celui qui j'avais ce matin à six heures.

Ne serais trop abusé de vous demander si il est possible de finir ce travail.

En fait je pensais faire avec les fonctions index/equiv pour remplir les cellules des données maintenant en ligne.

J'ai donc épuré le tableau et masqué seulement deux feuilles qui n'ont pas lieu d'être.

Ce qu'il reste ce sont deux choses à faire comme il vous convient pour l'ordre.

En colonne F il faut que pour chaque groupes de lignes l'article père(colonne D) soit répété. Pour exemple:

groupe de ligne 2-9 article père en D2 se répète en D38.

Puis pour remplir les cellules des articles, durant mes cinq heures de dur labeur j'ai quand même eu le temps de remplir les opérations et toute les familles enfin sans grande fierté un simple trie/filtre copier collé et le tour et joué.

Mais pour vous aider "si besoin" j'ai en colonne AP fait apparaître un critère de recherche pour dire quelle ligne à besoin d'être traitée. Pour votre macro ne la faire commencer qu'à partir de la ligne 9 car les 8 premières lignes ne provienne pas de ma base vous aurez certainement des erreurs.

Puis dans la feuille "Tableau de correspondance" toutes les correspondances des cellules à rechercher dans la feuille matériaux.

Pour exemple :

Feuille "Mo" ligne 45 l'article (Colonne C) au nom de "billmat14" je souhaite faire apparaître la désignation en colonne E.

Il faut donc aller chercher cet article dans la feuille matériaux en colonne C.
Par rapport à ce tableau de correspondances on sait que la valeur en colonne E se retrouve en D dans la feuille matériaux.....

Je serais étonné et surtout admiratif de voir en combien de temps cela sera fait. A vu de nez comment mon ordi réagit tout de suite... sans macro j'en ai pour 8-9h.

Encore merci pour votre aide qui n'est pas négligeable job75

Free - Envoyez vos documents

J'ai voulu essayer votre site pour le partage du fichier mais celui n'a pas l'air de vouloir fonctionner avec un fichier de plus de 15MO.

Que pourrais-je faire pour réduire le poids du fichier pour que d'autres personnes qui suivent la discussion pour leurs propres besoins puissent le consulter?

 

[oxychene]

Re : Création de X lignes par rapport à une cellule

groupe de ligne 2-9 article père en D2 se répète en D3 : D8

désolé un smiley s'est incrusté

 

[job75]

Re : Création de X lignes par rapport à une cellule

Bonjour oxychene, le forum,

Pas compris grand-chose et pas du tout envie de chercher à comprendre

Tout ce que je vois c'est que vous avez mis des "O" (???) à droite des "Mo_taux_3" et inséré une colonne A avec une nouvelle numérotation.

Il est facile de faire ça automatiquement :

Sub InsereLignes()
Dim duree#, deb As Range, ncol%, derlig&, P As Range, rc&, t, tref%(), rest(), i&, n&, j%, n1%
duree = Timer
Set deb = [A9:BL9] '1ère ligne du tableau
ncol = deb.Columns.Count 'nombre de colonnes du tableau
derlig = Cells(Rows.Count, deb.Column).End(xlUp).Row
If derlig < deb.Row Then Exit Sub
Set P = deb.Resize(derlig - deb.Row + 1)
rc = P.Rows.Count
t = P.FormulaR1C1
ReDim tref(1 To UBound(t), 1 To 2) 'au moins 2 éléments
'---tableau des résultats---
ReDim rest(1 To rc + Application.CountA(Range(P.Columns(40), P.Columns(ncol))), 1 To ncol)
For i = 1 To rc
  n = n + 1
  For j = 1 To ncol
    rest(n, j) = t(i, j)
  Next
  n1 = 0
  For j = 40 To ncol 'transfert des colonnes AN à BL...
    If t(i, j) = "" Then Exit For
    If LCase(t(i, j - 1)) Like "mo?taux*" Then
      rest(n + n1, 36) = t(i, j) '...en colonne AJ
    Else
      n1 = n1 + 1
      rest(n + n1, 2) = t(i, j) '...en colonne B
      If LCase(t(i, j)) Like "mo?taux*" Then rest(n + n1, 3) = "O" '???
    End If
  Next
  tref(i, 1) = n1 + 1
  n = n + tref(i, 1)
Next
Application.ScreenUpdating = False
Application.EnableEvents = False ' si macros évènementielles
Application.Calculation = xlCalculationManual 'si formules volatiles dans le classeur
'---effacement du tableau---
P = ""
'---insertion réelle de lignes---
For i = rc To 1 Step -1
  P(i + 1, 1).Resize(tref(i, 1)).EntireRow.Insert
  Application.StatusBar = "Réalisé " & Int(100 * (rc - i + 1) / rc) & " %" _
    & " - Lignes restantes " & i - 1
Next
'---restitution des formules et valeurs---
deb.Resize(n, ncol) = rest
[AN:BL].Clear 'facultatif, effacement de la zone transférée
[A:A].Insert
[A:A].NumberFormat = "00000"
With [A1].Resize(n + deb.Row - 1)
  .Value = "=ROW()" 'nouvelle numérotation
  .Value = .Value
End With
Cells.WrapText = False 'évite les renvois à la ligne
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
duree = Timer - duree
MsgBox "Durée " & Int((duree) / 60) & " mn " & Round(duree - 60 * Int((duree) / 60)) & " s"
End Sub

A+