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.
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.
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
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.