message VBA excel

[matrix]

Bonjour à tous,

Dans mon fichier excel, dans la colonne A, ce trouve des noms de personnes.

Dans la colonne I il y a des dates qui correspond avec les noms de la même ligne.

Je voudrais faire en sorte qui si le nom de la personne dans la colonne A apparait plus de 6 fois dans les 6 derniers mois (date de la colonne I), il me donne un message (msg).

Comment faire svp.

Merci de votre aide!

 

[Cousinhub]

Re : message VBA excel

Bonjour,
regarde le fichier joint
les deux plages sont nommées par le code
Tu peux modifier la condition finale (ici, j'ai mis >=, tu peux mettre >)

le code :

Sub avertissement()
Dim cel As Range, i
Dim pl As Range
Set pl = Range("A3:A" & Range("A65536").End(xlUp).Row)
pl.Name = "Plg"
Set pl = Range("I3:I" & Range("A65536").End(xlUp).Row)
pl.Name = "LesDates"
Set mondico = CreateObject("Scripting.Dictionary")
  For Each cel In [Plg]
   If Not mondico.Exists(cel.Value) And cel.Value <> "" Then
      mondico.Add cel.Value, cel.Value
   End If
  Next cel
For Each i In mondico
    If Evaluate("SUMPRODUCT((plg=""" & i & """)*(lesdates>=(DATE(YEAR(MAX(lesdates)),MONTH(MAX(lesdates))-6,DAY(MAX(lesdates))))))") >= 6 Then _
        MsgBox "Mr " & i & " apparaît plus de 6 fois"
Next i
End Sub

 

[matrix]

Re : message VBA excel

Merci beaucoup, ça fonctionne très bien.

Mais je remarque que j'ai pour au moin 62 msg un à la suite de l'autre.

est-il possible de transférer les données à la place dans une autre feuille nommé "compilation"?

 

[Cousinhub]

Re : message VBA excel

Bonsoir,

Mais je remarque que j'ai pour au moin 62 msg un à la suite de l'autre.

Et encore, tu as de la chance....
comme seuls les noms uniques sont traités, tu n'as que 62 msg....

A la place d'un MsgBox, tu peux inscrire les données dans une autre feuille, comme ceci :
En colonne A : le nom
En colonne B : le nombre de fois où il apparait

 

[matrix]

Re : message VBA excel

Merci beaucoup

J'ai même fais quelque modification:

Application.ScreenUpdating = False

' supprimer cellules feuille frequence
 Sheets("frequence").Select
    Sheets("frequence").Range("A2:D4221").Select
    Selection.EntireRow.Delete
    Sheets("frequence").Range("A1").Select
    

Sheets("Base de donnée").Select
ActiveSheet.Unprotect
Dim cel As Range
Dim pl As Range
Set pl = Range("A3:A" & Range("A65536").End(xlUp).Row)
pl.Name = "Plg"
Set pl = Range("I3:I" & Range("A65536").End(xlUp).Row)
pl.Name = "LesDates"
Set mondico = CreateObject("Scripting.Dictionary")
  For Each cel In [Plg]
   If Not mondico.Exists(cel.Value) And cel.Value <> "" Then
      mondico.Add cel.Value, cel.Value
   End If
  Next cel
For Each i In mondico
    x = Evaluate("SUMPRODUCT((plg=""" & i & """)*(lesdates>=(DATE(YEAR(MAX(lesdates)),MONTH(MAX(lesdates))-6,DAY(MAX(lesdates))))))")
    If x >= 6 Then
        With Sheets("frequence")
        derlig = .[A65000].End(xlUp).Row + 1
            .Cells(derlig, 1).Value = i
            .Cells(derlig, 2).Value = x
            .Cells(derlig, 3).Value = Date
            .Cells(derlig, 4).Value = Time
              
        End With
    End If
Next i

Sheets("Base de donnée").Select
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False


Sheets("frequence").Select
 Sheets("frequence").Columns("A:D").Select
    ActiveWorkbook.Worksheets("frequence").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("frequence").Sort.SortFields.Add Key:=Range( _
        "B2:B42"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("frequence").Sort
        .SetRange Range("A1:D42")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("frequence").Range("A1").Select
    
    
    
    
    
    'RechercheV status des employés    
       Sheets("frequence").Range("E2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],Employés!C1:C2,2,0)"
    Selection.AutoFill Destination:=Sheets("frequence").Range("E2:E1423"), Type:=xlFillDefault
    Sheets("frequence").Range("E2:E1423").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Replace What:="Régulier", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="Partiel", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="Chauffeur", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    ActiveWindow.SmallScroll Down:=-27
    Sheets("frequence").Range("E1").Select
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ColorIndex = 6
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    ActiveCell.FormulaR1C1 = "Status"
    Sheets("frequence").Range("D1").Select
    Selection.Copy
    Sheets("frequence").Range("E1").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Sheets("frequence").Columns("A:E").Select
    ActiveWorkbook.Worksheets("frequence").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("frequence").Sort.SortFields.Add Key:=Range( _
        "E2:E1423"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("frequence").Sort
        .SetRange Range("A1:E1423")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("frequence").Range("A1").Select
    
    
'Supprimer tous sauf Étudiant

derlig = Sheets("frequence").Range("A200").End(xlUp).Row
  For i = 1 To derlig
    If Sheets("frequence").Cells(i, 5).Value = "" Then Sheets("frequence").Cells(i, 4).Clear
    If Sheets("frequence").Cells(i, 5).Value = "" Then Sheets("frequence").Cells(i, 3).Clear
    If Sheets("frequence").Cells(i, 5).Value = "" Then Sheets("frequence").Cells(i, 2).Clear
    If Sheets("frequence").Cells(i, 5).Value = "" Then Sheets("frequence").Cells(i, 1).Clear
Next
Application.ScreenUpdating = True

Merci encore!