Insertion de ligne puis de formules dans un tableau

Bonjour,

Bonne année à tous. Je suis nouveau dans le domaine de la programmation sur excel.

Je pense que le sujet a deja etait abordées plusieurs fois, mais je n'ai pas trouvé bonheurs à mon problème.

J'aurais besoin d'une petite aide. J'ai un tableau avec plusieurs valeurs. Dans un premier temps j'aimerais effectuer un tri par ordre croissant vis-à-vis d'une colonne. Pour cela j'ai déjà réalisé une macro et ça marche nickel.

Mon problème arrive par la suite. J'aimerais effectuer une macro (ou plusieurs) pour regrouper les lignes qui ont un chiffre en commun, avec une insertion de ligne.

Par la suite il faudrait que dans les lignes rajoutées des formules de somme viennent s'ajouter.

Je ne sais pas si je me suis bien fait comprendre.

Je vous joins un fichier avec le résultat après mon tri, et ce que j'aimerais obtenir.

D'avance je vous remercie pour l'aide.

17tableau-de-coupe.xlsm (148.79 Ko)

Bonjour et Bonne année à toi également,

à tester,

Sub test()
Application.ScreenUpdating = False

Sheets("Debut").Copy After:=Sheets(2)
ActiveSheet.Name = "test"
Derlig = Sheets("test").Range("A" & Rows.Count).End(xlUp).Row + 1

Nb = Range("B10:B" & Derlig).Address
Brut = Range("C10:C" & Derlig).Address
Largeur_brute = Range("E10:E" & Derlig).Address
Largeur_finale = Range("F10:F" & Derlig).Address
Poids_brute = Range("H10:H" & Derlig).Address
Poids_Final = Range("I10:I" & Derlig).Address

For i = Derlig - 1 To 10 Step -1
    If Cells(i, 3) <> Cells(i - 1, 3) Then
        Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Range("A" & i & ":I" & i).Interior.Color = RGB(217, 217, 217)
        Range("C" & i).Value = Range("C" & i + 1).Value
        Range("B" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Nb & "))")
        Range("E" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Largeur_brute & "))")
        Range("F" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Largeur_finale & "))")
        Range("H" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Poids_brute & "))")
        Range("I" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Poids_Final & "))")
    End If
Next
Application.ScreenUpdating = True
End Sub

Super !!!! Cela fonction au poile !!

Est-il possible de mettre en gras les nombres qui sont créer avec les insertions de ligne ?

Bonjour,

oui,

'juste après cette ligne,
Range("A" & i & ":I" & i).Interior.Color = RGB(217, 217, 217)
'ajouter cette ligne,
Range("A" & i & ":I" & i).Font.Bold = True

Nickel.

Je te remercie de m'avoir aidé.

Bonne journée à toi

J'ai une dernière question.

J'aimerais ajouter à la somme créer dans largeur finale (au niveau des sous ensemble) une formule.

La formule permettrait de faire:

Somme des largeur finale du sous ensemble (associé a la ligne créer) + (7 x le nombre)

Je ne sais pas si on comprend de quoi je parle ^^

Merci d'avance pour l'aide

Bonjour,

J'aimerais ajouter à la somme créer dans largeur finale (au niveau des sous ensemble) une formule.

La formule permettrait de faire:

Somme des largeur finale du sous ensemble (associé a la ligne créer) + (7 x le nombre)

Je ne sais pas si on comprend de quoi je parle ^^

par exemple si le résultat de la somme actuelle d'un sous-ensemble est de 10

vous aimeriez que ce résultat soit de 80 ?

Bonjour,

Si dans un sous ensemble qui est égale a 100 en colonne F, mais dans se sous ensemble j'ai que 4 pièces différentes en B, cela ferai

100 + (7*B).

J'ai actuellement le code que l'on ma donné:

Sub test()
Application.ScreenUpdating = False

Derlig = Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Row + 1

Nb = Range("B9:B" & Derlig).Address
Brut = Range("C9:C" & Derlig).Address
Largeur_brute = Range("E9:E" & Derlig).Address
Largeur_finale = Range("F9:F" & Derlig).Address
Poids_brute = Range("H9:H" & Derlig).Address
Poids_Final = Range("I9:I" & Derlig).Address

For I = Derlig - 1 To 9 Step -1
    If Cells(I, 3) <> Cells(I - 1, 3) Then
        Rows(I).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Range("A" & I & ":I" & I).Interior.Color = RGB(217, 217, 217)
        Range("A" & I & ":I" & I).Font.Bold = True
        Range("C" & I).Value = Range("C" & I + 1).Value
        Range("B" & I) = Evaluate("Sumproduct((" & Brut & "=" & Cells(I, 3).Value & ")*(" & Nb & "))")
        Range("E" & I) = Evaluate("Sumproduct((" & Brut & "=" & Cells(I, 3).Value & ")*(" & Largeur_brute & "))")
        Range("F" & I) = Evaluate("Sumproduct((" & Brut & "=" & Cells(I, 3).Value & ")*(" & Largeur_finale & "))")
        Range("H" & I) = Evaluate("Sumproduct((" & Brut & "=" & Cells(I, 3).Value & ")*(" & Poids_brute & "))")
        Range("I" & I) = Evaluate("Sumproduct((" & Brut & "=" & Cells(I, 3).Value & ")*(" & Poids_Final & "))")
    End If
Next
Application.ScreenUpdating = True
End Sub

J'ai rajouté cette ligne juste avant "End If"

        Range("F" & I).Select
    ActiveCell.FormulaR1C1 = "=SUM(7*RC[-3]+(SUM(R[1]C:R[3]C)))"

Cela fonctionne à peut prêt, mais le problème, c'est qu 'il me sélectionne obligatoirement 3 ligne, or mon chant d'action peut varier. De plus, il me fait la somme par rapport a la colonne C et non la B.

par exemple pour les données suivante, quel serait le résultat attendu ?

trysonne resultat attendu

Pour l'exemple:

Pour 17.06 -> 24.06 car (17.06+(7x1))

Pour 130 -> 144 car (130+(7x2))

Pour 251.32 -> 286.32 car (251.32+(7x5))

Bonjour,

voici la modification,

Sub test()
Application.ScreenUpdating = False

Sheets("Debut").Copy After:=Sheets(2)
ActiveSheet.Name = "test"
Derlig = Sheets("test").Range("A" & Rows.Count).End(xlUp).Row + 1

Nb = Range("B10:B" & Derlig).Address
Brut = Range("C10:C" & Derlig).Address
Largeur_brute = Range("E10:E" & Derlig).Address
Largeur_finale = Range("F10:F" & Derlig).Address
Poids_brute = Range("H10:H" & Derlig).Address
Poids_Final = Range("I10:I" & Derlig).Address

For i = Derlig - 1 To 10 Step -1
    If Cells(i, 3) <> Cells(i - 1, 3) Then
        Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Range("A" & i & ":I" & i).Interior.Color = RGB(217, 217, 217)
        Range("A" & i & ":I" & i).Font.Bold = True
        Range("C" & i).Value = Range("C" & i + 1).Value
        Range("B" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Nb & "))")
        Range("E" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Largeur_brute & "))")
        n = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Largeur_finale & "))")
        Range("F" & i) = n + (7 * Range("B" & i))
        Range("H" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Poids_brute & "))")
        Range("I" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Poids_Final & "))")
    End If
Next
Application.ScreenUpdating = True
End Sub

Vraiment super ! Je te remercie encore.

J'ai un dernier soucis pour finir. J'aimerais que le document on ne puisse enregistrer sur l'original. J'ai tenté de l'enregistrer en .xltm, mais les macro ne fonctionne plus derrière

A tu un moyen pour que l'on ne puisse que enregistrer le fichier avec "enregistrer sous" ?

Bonjour,

Je reviens vers vous car j'ai supprimé une colonne de mon tableau, j'ai donc modifié en conséquence les macros. Le problème c'est que j'ai changé de type de valeur dans une colonne (celle des Ø bruts), à présent je doit utiliser des chiffres à virgule. Le problème c'est que plus aucune macro ne fonctionne

J'aimerais que le document on ne puisse enregistrer sur l'original. J'ai tenté de l'enregistrer en .xltm, mais les macro ne fonctionne plus derrière

à tester, copier cette macro sur la page code de thisworkbook,

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Sauvegarde As Variant, Question As Integer
Application.EnableEvents = False

chemin = ThisWorkbook.Path
Sauvegarde = Application.GetSaveAsFilename(chemin & "\" & "copie_de_" & ActiveWorkbook.Name, FileFilter:="XLSM (*.xlsm), *.xlsm", Title:="Sauvez moi vite ...")
If Sauvegarde = False Then Exit Sub
If Dir(Sauvegarde) <> "" Then ' le fichier renseigné par l'utilisateur existe-t-il ?
   Question = MsgBox("Attention le fichier existe déjà" & Chr(13) & "Voulez vous le remplacer ?", vbQuestion + vbYesNo, "Attention...")
   ' Si oui, faut t-il l'effacer ?
   If Question = 6 Then ' Oui
      Kill Sauvegarde ' Efface
   Else ' Non
      Exit Sub ' Stop procédure
   End If
End If

ThisWorkbook.SaveAs Sauvegarde ' Sauvegarde
Cancel = True
Application.EnableEvents = True
End Sub

2ème question:

J'ai un dernier soucis pour finir. J'aimerais que le document on ne puisse enregistrer sur l'original. J'ai tenté de l'enregistrer en .xltm, mais les macro ne fonctionne plus derrière

pouvez-vous joindre votre nouveau fichier ?

Bonjour,

Je n’ai pas encore pris le temps de tester la macro pour la sauvegarde.

Je joint également le tableau et les macros (je ne sais pas si elle suive quand je le passe comme ça)

C'est le code qui me servait à trier

Sub Macro1()
'
' Macro1 Macro
'

'
    Cells.Replace What:=",", Replacement:=".", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    'Range("C9:C600").Select
    ActiveWindow.SmallScroll Down:=-108
    ActiveWorkbook.Worksheets("Feuil2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil2").Sort.SortFields.Add Key:=Range("C9"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil2").Sort
        .SetRange Range("A8:H600")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'Range("J11").Select
End Sub
Sub Macro3()
'
' Macro3 Macro
'

'
    Application.Run "Macro1"
    Range("C9:C600").Select
    Selection.TextToColumns Destination:=Range("C9"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    ActiveWindow.SmallScroll Down:=-15
    Application.Run "'Feuille de coupe vierge.xlsm'!Macro1"
    Selection.TextToColumns Destination:=Range("C9"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    Range("E9:E600").Select
    Selection.TextToColumns Destination:=Range("E9"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    Range("G9:G600").Select
    Selection.TextToColumns Destination:=Range("G9"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    Range("H9:H600").Select
    Selection.TextToColumns Destination:=Range("H9"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    Range("D9:D600").Select
    Selection.TextToColumns Destination:=Range("D9"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    Range("B9:B600").Select
    Selection.NumberFormat = "0"
    Range("C9:C600").Select
    Selection.NumberFormat = "0.0"
    Range("L12").Select
End Sub

Le code pour créer les lignes qui m'a était conseiller de faire.

Sub test()
Application.ScreenUpdating = False

Derlig = Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Row + 1

Nb = Range("B9:B" & Derlig).Address
Brut = Range("C9:C" & Derlig).Address
Largeur_finale = Range("E9:E" & Derlig).Address
Poids_brut = Range("G9:G" & Derlig).Address
Poids_Final = Range("H9:H" & Derlig).Address

For i = Derlig - 1 To 9 Step -1
    If Cells(i, 3) <> Cells(i - 1, 3) Then
        Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Range("A" & i & ":H" & i).Interior.Color = RGB(217, 217, 217)
        Range("A" & i & ":H" & i).Font.Bold = True
        Range("C" & i).Value = Range("C" & i + 1).Value
        Range("B" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Nb & "))")
        n = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Largeur_finale & "))")
        Range("E" & i) = n + (7 * Range("B" & i))
        Range("G" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Poids_brut & "))")
        Range("H" & i) = Evaluate("Sumproduct((" & Brut & "=" & Cells(i, 3).Value & ")*(" & Poids_Final & "))")
    End If
Next
Application.ScreenUpdating = True
End Sub
1tableau-galet.xlsm (96.31 Ko)

Bonjour,

voici la modification,

Bonjour,

J'ai testé la macro que tu viens de m'envoyer et cela ne marche pas

Je te renvoie une fichier sans macro. Avec les deux macro que j'aimerais.

J'ai créer plusieurs feuilles mais il faudrait que tout se face sur une seul feuille.

1tableau-galet.xlsm (219.71 Ko)
Rechercher des sujets similaires à "insertion ligne puis formules tableau"