Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionPrivate Sub CommandButton1_Click() Dim colonne_concernee As String, a_partir_ligne As Integer, ecreter_de_combien As Long colonne_concernee = "B" 'ou la colonne de ton choix a_partir_ligne = 2 'ou la ligne de ton choix ecreter_de_combien = 4 'ou le nombre d'écrétaement de ton choix epurer colonne_concernee, a_partir_ligne, ecreter_de_combien End Sub
Private Sub epurer(ByVal col As String, ByVal ligne As Integer, ByVal nb As Integer) Dim plage As Range, plage_a_supp As Range Dim n As Long, i As Long, j As Long, msg As String 'n = ActiveSheet.UsedRange.Rows.Count n = Range(col & Rows.Count).End(xlUp).Row nb = 4 'pour ôter 4 lignes en bas et 4 en haut If nb = 0 Then Exit Sub msg = "" For i = ligne + 1 To n + 1 If Range(col & i).Value = Range(col & i - 1).Value Then If plage Is Nothing Then Set plage = Union(Range(col & i - 1), Range(col & i)) Else Set plage = Union(plage, Range(col & i)) End If Else If plage.Rows.Count >= nb * 2 Then For j = 1 To nb If plage_a_supp Is Nothing Then Set plage_a_supp = Union(plage(1, 1), plage(plage.Rows.Count, 1)) Else Set plage_a_supp = Union(plage_a_supp, plage(j, 1), plage(plage.Rows.Count + 1 - j, 1)) End If Next Set plage = Range(col & i) If Range(col & i).Value = "" Then Exit For Else msg = msg & " - " & plage(1, 1).Value Set plage = Nothing If Range(col & i).Value = "" Then Exit For End If End If Next If Not plage_a_supp Is Nothing Then plage_a_supp.Rows.EntireRow.Delete End If If msg <> "" Then MsgBox "les groupes suivants, d'un nombre non suffisant, " & _ "n'ont pas été traités " & vbCrLf & Mid(msg, 3) End If End Sub
nb = 4 'pour ôter 4 lignes en bas et 4 en haut
Private Sub on_amenage(ByVal col As String, ByVal ld As Integer, ByVal moy, ByVal dif) Dim deb As Long, n As Long, i As Long, combien As Long, k As Long, j As Long Dim plage As Range, plage_a_supp As Range Dim elmt deb = Range(col & ":" & col).Column n = Range(col & Rows.Count).End(xlUp).Row For i = ld + 1 To n + 1 If Range(col & i).Value = Range(col & i - 1).Value Then If plage Is Nothing Then Set plage = Union(Range(col & i - 1), Range(col & i)) Else Set plage = Union(plage, Range(col & i)) End If Else If Not plage Is Nothing Then combien = plage.Rows.Count If combien > 1 Then For Each elmt In moy k = Range(elmt & ":" & elmt).Column - deb + 1 plage.Cells(1, k) = WorksheetFunction.Average(plage.Columns(k)) Next For Each elmt In dif k = Range(elmt & ":" & elmt).Column - deb + 1 plage.Cells(1, k).Value = plage(plage.Rows.Count, k).Value - plage(1, k).Value Next For j = 2 To combien If plage_a_supp Is Nothing Then Set plage_a_supp = plage(j, 1) Else Set plage_a_supp = Union(plage_a_supp, plage(j, 1)) End If Next End If Set plage = Nothing End If End If Next If Not plage_a_supp Is Nothing Then plage_a_supp.Rows.EntireRow.Delete End If End Sub
Private Sub CommandButton1_Click() Dim colonne_concernee As String, a_partir_ligne As Integer, ecreter_de_combien As Long colonne_concernee = "B" 'ou la colonne de ton choix a_partir_ligne = 2 'ou la ligne de ton choix ecreter_de_combien = 4 'ou le nombre d'écrétaement de ton choix epurer colonne_concernee, a_partir_ligne, ecreter_de_combien Dim colonne_groupes As String Dim colonnes_moyennes, colonnes_diff colonne_groupes = "B" a_partir_ligne = 1 colonnes_moyennes = Array("D", "E", "F", "G") colonnes_diff = Array("C") on_amenage colonne_groupes, a_partir_ligne, colonnes_moyennes, colonnes_diff End Sub
Sub ma_big_macro() Dim colonne_concernee As String, a_partir_ligne As Integer, ecreter_de_combien As Long colonne_concernee = "A" 'ou la colonne de ton choix a_partir_ligne = 1 'ou la ligne de ton choix ecreter_de_combien = 4 'ou le nombre d'écrétaement de ton choix epurer colonne_concernee, a_partir_ligne, ecreter_de_combien Dim colonne_groupes As String Dim colonnes_moyennes, colonnes_diff colonne_groupes = "A" a_partir_ligne = 1 colonnes_moyennes = Array("D", "E", "F") colonnes_diff = Array("C") on_amenage colonne_groupes, a_partir_ligne, colonnes_moyennes, colonnes_diff End Sub
Public Sub epurer(ByVal col As String, ByVal ligne As Integer, ByVal nb As Integer) Dim plage As Range, plage_a_supp As Range Dim n As Long, i As Long, j As Long, msg As String n = Range(col & Rows.Count).End(xlUp).Row If nb = 0 Then Exit Sub msg = "" For i = ligne + 1 To n + 1 If Range(col & i).Value = Range(col & i - 1).Value Then If plage Is Nothing Then Set plage = Union(Range(col & i - 1), Range(col & i)) Else Set plage = Union(plage, Range(col & i)) End If Else If plage.Rows.Count >= nb * 2 Then For j = 1 To nb If plage_a_supp Is Nothing Then Set plage_a_supp = Union(plage(1, 1), plage(plage.Rows.Count, 1)) Else Set plage_a_supp = Union(plage_a_supp, plage(j, 1), plage(plage.Rows.Count + 1 - j, 1)) End If Next Set plage = Range(col & i) If Range(col & i).Value = "" Then Exit For Else msg = msg & " - " & plage(1, 1).Value Set plage = Nothing If Range(col & i).Value = "" Then Exit For End If End If Next If Not plage_a_supp Is Nothing Then plage_a_supp.Rows.EntireRow.Delete End If If msg <> "" Then MsgBox "les groupes suivants, d'un nombre non suffisant, " & _ "n'ont pas été traités " & vbCrLf & Mid(msg, 3) End If End Sub Public Sub on_amenage(ByVal col As String, ByVal ld As Integer, ByVal moy, ByVal dif) Dim deb As Long, n As Long, i As Long, combien As Long, k As Long, j As Long Dim plage As Range, plage_a_supp As Range Dim elmt deb = Range(col & ":" & col).Column n = Range(col & Rows.Count).End(xlUp).Row For i = ld + 1 To n + 1 If Range(col & i).Value = Range(col & i - 1).Value Then If plage Is Nothing Then Set plage = Union(Range(col & i - 1), Range(col & i)) Else Set plage = Union(plage, Range(col & i)) End If Else If Not plage Is Nothing Then combien = plage.Rows.Count If combien > 1 Then For Each elmt In moy k = Range(elmt & ":" & elmt).Column - deb + 1 plage.Cells(1, k) = WorksheetFunction.Average(plage.Columns(k)) Next For Each elmt In dif k = Range(elmt & ":" & elmt).Column - deb + 1 plage.Cells(1, k).Value = plage(plage.Rows.Count, k).Value - plage(1, k).Value Next For j = 2 To combien If plage_a_supp Is Nothing Then Set plage_a_supp = plage(j, 1) Else Set plage_a_supp = Union(plage_a_supp, plage(j, 1)) End If Next End If Set plage = Nothing End If End If Next If Not plage_a_supp Is Nothing Then plage_a_supp.Rows.EntireRow.Delete End If End Sub
If plage.Rows.Count >= nb * 2 Then
Private Sub on_amenage() Dim lesquels As Integer lesquels = 14 n = Range("B" & Rows.Count).End(xlUp).Row Dim plage As Range, plage_a_supp As Range, combien As Integer For i = 6 To n + 1 If Range(" B" & i).Value = Range("B" & i - 1).Value Then If plage Is Nothing Then Set plage = Union(Range("B" & i - 1), Range("B" & i)) Else Set plage = Union(plage, Range("B" & i)) End If Else If Not plage Is Nothing Then combien = plage.Rows.Count If combien > 1 Then For k = 2 To lesquels + 1 Select Case k Case 3, 14, 15 plage.Cells(1, k) = WorksheetFunction.Average(plage.Columns(k)) Case 2 plage.Cells(1, k).Value = plage(plage.Rows.Count, k).Value - plage(1, k).Value End Select Next For j = 2 To combien If plage_a_supp Is Nothing Then Set plage_a_supp = plage(j, 1) Else Set plage_a_supp = Union(plage_a_supp, plage(j, 1)) End If Next End If Set plage = Nothing End If End If Next If Not plage_a_supp Is Nothing Then plage_a_supp.Rows.EntireRow.Delete End If End Sub
If plage.Rows.Count >= nb * 2 Then
' ================================c'est ici, que tu définis les autres paramètres ========================================= colonne_groupes = "A" '<<<<<<<======== ici : la colonne des groupes a_partir_ligne = 1 '<<<<<<============ ici : la ligne où commencent les groupes ecreter_de_combien = 4 '<<<<======= ici : de combien écréter en haut et en bas de chaque groupe colonnes_moyennes = Array("C", "D", "E") '<<<<=== ici : énumération des colonnes où faire la moyenne ("") si aucune colonnes_diff = Array("B") ' <<<<<===== ici : énumération des colonnes où faire tes "différences" ("") si aucune col_groupes = Array(colonne_groupes) ' ---->> ça, c'est pour le code. Ne t'en préoccupe pas. '==========================================================================================================================
Sub SUPPRESSION_MOYENNE_DIFFERENCE() Cells.Clear ' Vide la feuille Dim plage As Range, plage_a_supp As Range Dim nb As Long, n As Long, i As Long, j As Long, msg As String Dim t, ii As Byte t = Split("1 11 21 31") 'Permet de créer une petite table pour exemple For ii = 0 To 3 Cells(t(ii), 1).Resize(10) = ii Cells(t(ii), 2).Resize(10) = [=TRANSPOSE({1,2,3,4,5,6,7,8,9,10})] Next ii Cells(41, 1).Value = 3 Cells(42, 1).Value = 3 Cells(43, 1).Value = 3 Cells(44, 1).Value = 3 Cells(45, 1).Value = 3 Cells(41, 2).Value = 11 Cells(42, 2).Value = 12 Cells(43, 2).Value = 13 Cells(44, 2).Value = 14 Cells(45, 2).Value = 15 Columns("A:B").Select Selection.Copy Columns("C:C").Select ActiveSheet.Paste Columns("A:D").Select Application.CutCopyMode = False Selection.Copy Columns("E:E").Select ActiveSheet.Paste Application.CutCopyMode = False 'Range("A45:H45").Select 'Selection.ClearContents Dim feuille_donnees As String Dim colonne_groupes As String, a_partir_ligne As Integer, ecreter_de_combien As Long Dim colonnes_moyennes, colonnes_diff ' ==============================c'est ici que tu définis la feuille des données ========================================== feuille_donnees = "Feuil1" ' <<<<<========= le nom exact de la feuille contenant les groupes à traiter ''c'est ici, que tu définis les autres paramètres ========================================= colonne_groupes = "A" '<<<<<<<======== ici : la colonne des groupes a_partir_ligne = 1 '<<<<<<============ ici : la ligne où commencent les groupes ecreter_de_combien = 2 '<<<<======= ici : de combien écréter en haut et en bas de chaque groupe colonnes_moyennes = Array("A", "C", "D", "E", "F", "G", "H") '<<<<=== ici : énumération des colonnes où faire la moyenne ("") si aucune colonnes_diff = Array("B") ' <<<<<===== ici : énumération des colonnes où faire tes "différences" ("") si aucune col_groupes = Array(colonne_groupes) ' ---->> ça, c'est pour le code. Ne t'en préoccupe pas. '========================================================================================================================== ' ________________________________________ les gardes-fou, maintenant ________________________________________________ If ActiveSheet.Name <> feuille_donnees Then MsgBox "cette opération ne doit être lancée que si la feuille " & feuille_donnees & " est la feuille active" Exit Sub End If If verif(col_groupes, colonne_groupes, a_partir_ligne, "colonne des groupes") = False Then Exit Sub If verif(colonnes_moyennes, colonne_groupes, a_partir_ligne, "colonne à moyenne") = False Then Exit Sub If verif(colonnes_diff, colonne_groupes, a_partir_ligne, "colonne à différence") = False Then Exit Sub '______________________________________________________________________________________________________________________ ' ------------------------------ si l'exécution atteint ce point, c'est que tout est cohérent ------------------------- ' ------------------------------ on y va donc ------------------------------------------------------------------------- ' ---------------------------------------------"écrétant" d'abord------------------------------------------------------ epurer colonne_groupes, a_partir_ligne, ecreter_de_combien ' ----------------------------------------puis en traitant le reste (écart(s) et moyenne(s) --------------------------- on_amenage colonne_groupes, a_partir_ligne, colonnes_moyennes, colonnes_diff End Sub Public Sub epurer(ByVal col As String, ByVal ligne As Integer, ByVal nb As Integer) Dim plage As Range, plage_a_supp As Range Dim n As Long, i As Long, j As Long, msg As String n = Range(col & Rows.Count).End(xlUp).Row If nb = 0 Then Exit Sub msg = "" For i = ligne + 1 To n + 1 If Range(col & i).Value = Range(col & i - 1).Value Then If plage Is Nothing Then Set plage = Union(Range(col & i - 1), Range(col & i)) Else Set plage = Union(plage, Range(col & i)) End If ElseIf Not plage Is Nothing Then If plage.Rows.Count >= nb * 2 Then For j = 1 To nb If plage_a_supp Is Nothing Then Set plage_a_supp = Union(plage(1, 1), plage(plage.Rows.Count, 1)) Else Set plage_a_supp = Union(plage_a_supp, plage(j, 1), plage(plage.Rows.Count + 1 - j, 1)) End If Next Set plage = Range(col & i) If Range(col & i).Value = "" Then Exit For Else msg = msg & " - " & plage(1, 1).Value Set plage = Nothing If Range(col & i).Value = "" Then Exit For End If Else msg = msg & " - " & Cells(i - 1, 1).Value End If Next If Not plage_a_supp Is Nothing Then plage_a_supp.Rows.EntireRow.Delete End If If msg <> "" Then MsgBox "les groupes suivants, d'un nombre non suffisant, " & _ "n'ont pas été traités " & vbCrLf & Mid(msg, 3) End If End Sub Public Sub on_amenage(ByVal col As String, ByVal ld As Integer, ByVal moy, ByVal dif) Dim deb As Long, n As Long, i As Long, combien As Long, k As Long, j As Long Dim plage As Range, plage_a_supp As Range Dim elmt deb = Range(col & ":" & col).Column n = Range(col & Rows.Count).End(xlUp).Row For i = ld + 1 To n + 1 If Range(col & i).Value = Range(col & i - 1).Value Then If plage Is Nothing Then Set plage = Union(Range(col & i - 1), Range(col & i)) Else Set plage = Union(plage, Range(col & i)) End If Else If Not plage Is Nothing Then combien = plage.Rows.Count If combien > 1 Then If UBound(moy) > 0 Then For Each elmt In moy k = Range(elmt & ":" & elmt).Column - deb + 1 plage.Cells(1, k) = WorksheetFunction.Average(plage.Columns(k)) Next End If If UBound(dif) > 0 Then For Each elmt In dif k = Range(elmt & ":" & elmt).Column - deb + 1 plage.Cells(1, k).Value = plage(plage.Rows.Count, k).Value - plage(1, k).Value Next End If For j = 2 To combien If plage_a_supp Is Nothing Then Set plage_a_supp = plage(j, 1) Else Set plage_a_supp = Union(plage_a_supp, plage(j, 1)) End If Next End If Set plage = Nothing End If End If Next If Not plage_a_supp Is Nothing Then plage_a_supp.Rows.EntireRow.Delete End If End Sub Public Function verif(cols, colonne_groupes, a_partir_ligne, descr As String) As Boolean verif = True If UBound(cols) = 0 Then Exit Function derlig = Range(colonne_groupes & Rows.Count).End(xlUp).Row For Each elmt In cols Dim plage As Range Set plage = Nothing On Error Resume Next Set plage = Range(elmt & a_partir_ligne & ":" & elmt & derlig).SpecialCells(xlCellTypeBlanks) If Not plage Is Nothing Then MsgBox "la " & descr & " " & elmt & " contient une cellule vide - Corrigez puis relancez, s'il vous plait !" verif = False On Error GoTo 0 End If Next End Function