Amélioration de code

Le 08/05/2017 à 16:46

Bonjour le forum,

J'ai fais cette macro mais elle est très lente. Y aurait-il moyen de l'améliorer ? Merci.

Application.ScreenUpdating = False
Sheets("Prime").Unprotect
Dim C%, D%, NOM%, Nb%, iRowCP%, iRow%

iRow = Sheets("BDD").Cells(Rows.Count, 2).End(xlUp).Row

'Mise en forme de la feuille "Prime"
    With Sheets("Prime")
        .Range("B:E").Clear

        .Range("C3").Value = "Gardes Semaine"
        .Range("D3").Value = "Gardes Week-End"
        .Range("C3:D3").Font.Bold = True
        .Range("C:D").HorizontalAlignment = xlCenter
        .Range("C:D").VerticalAlignment = xlBottom
        .Range("B:B").Font.Bold = True

        .Range("C:D").NumberFormat = "dd/mm/yyyy"
'On ajoute les personnels
        Dep = 5
            For i = 2 To iRow
                .Range("B" & Dep).Value = Sheets("BDD").Range("F" & i).Value
                Dep = Dep + 11
            Next i

    End With

iRowD = Sheets("Données").Cells(Rows.Count, 2).End(xlUp).Row

'Nombre de personnels
Nb = Sheets("BDD").Cells(Rows.Count, 6).End(xlUp).Row

'On définit les 1ère ligne
C = 5: D = 5: NOM = 5

'Boucle (dates de gardes par personnel)
        For j = 1 To Nb

            'On efface la feuille "CherchePrime"
            With Sheets("CherchePrime")
            .Range("A:F").Clear
            End With

            'On filtre la feuille "Données" par "Nom"/"Date"/"PO et WPO"
            iRowD = Sheets("Données").Cells(Rows.Count, 2).End(xlDown).Row

            If Sheets("Données").AutoFilterMode Then
                               Sheets("Données").AutoFilterMode = False
            End If
            With Sheets("Données")
                .ListObjects("Tableau3").Range.AutoFilter Field:=3, _
                    Criteria1:=">=" & Format(Sheets("Prime").Range("O2"), "mm/dd/yy"), Operator:=xlAnd, _
                        Criteria2:="<=" & Format(Sheets("Prime").Range("P2"), "mm/dd/yy")
                Sheets("Données").ListObjects("Tableau3").Range.AutoFilter Field:=4, Criteria1:= _
                    "PO", Operator:=xlOr, Criteria2:="WPO"
                Sheets("Données").ListObjects("Tableau3").Range.AutoFilter Field:=2, Criteria1:= _
                    Sheets("Prime").Range("B" & NOM).Value
            End With

            'On copie les lignes visibles
            With Sheets("Données").Range("A2:F" & iRowD)
                            .SpecialCells(xlCellTypeVisible).Copy
                            Sheets("CherchePrime").Select
                            Range("A2").Select
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                             :=False, Transpose:=False
            End With
            If Sheets("CherchePrime").Range("A3").Value = "" Then
            iRowCP = 2
            Else
            iRowCP = Sheets("CherchePrime").Cells(2, 2).End(xlDown).Row
            End If
            For i = 2 To iRowCP
                If Sheets("CherchePrime").Range("F" & i).Value = Sheets("Prime").Range("B" & NOM).Value & "PO" Then
                    Sheets("Prime").Range("C" & C).Value = Sheets("CherchePrime").Range("C" & i).Value
                    C = C + 1
                ElseIf Sheets("CherchePrime").Range("F" & i).Value = Sheets("Prime").Range("B" & NOM).Value & "WPO" Then
                    Sheets("Prime").Range("D" & D).Value = Sheets("CherchePrime").Range("C" & i).Value
                    D = D + 1
                End If
            Next i

        NOM = NOM + 11
            C = 5 + (11 * j)
            D = 5 + (11 * j)
            iRowD = 0
        Next j

Dim iRowPO%, iRowWPO%, iRowMax%

iRowPO = Sheets("Prime").Cells(Rows.Count, 3).End(xlUp).Row
iRowWPO = Sheets("Prime").Cells(Rows.Count, 4).End(xlUp).Row
If iRowWPO > iRowPO Then
iRowMax = iRowWPO
Else
iRowMax = iRowPO
End If

For i = iRowMax To 6 Step -1
    If Sheets("Prime").Range("C" & i).Value = "" And Sheets("Prime").Range("D" & i).Value = "" Then
        Sheets("Prime").Range("C" & i).EntireRow.Delete
    End If
Next i

iRowPO = Sheets("Prime").Cells(Rows.Count, 3).End(xlUp).Row
iRowWPO = Sheets("Prime").Cells(Rows.Count, 4).End(xlUp).Row
If iRowWPO > iRowPO Then
iRowMax = iRowWPO
Else
iRowMax = iRowPO
End If

For i = 4 To iRowMax
   If Sheets("Prime").Range("B" & i).Value <> "" Then
   Sheets("Prime").Range("B" & i & ":D" & i).Borders(xlEdgeTop).LineStyle = xlContinuous
   End If
Next

Sheets("Prime").Range("C3:D" & iRowMax).Borders(xlEdgeRight).LineStyle = xlContinuous
Sheets("Prime").Range("C3:C" & iRowMax).Borders(xlEdgeRight).LineStyle = xlContinuous
Sheets("Prime").Range("C3:D" & iRowMax).Borders(xlEdgeLeft).LineStyle = xlContinuous

ActiveWorkbook.Worksheets("Données").ListObjects("Tableau3").Sort.SortFields. _
        Clear
    Sheets("Données").ShowAllData

 Sheets("prime").Select
  Sheets("Prime").Range("A1:A500").Interior.Color = RGB(124, 124, 124)
Sheets("Prime").Protect
Application.ScreenUpdating = True

16prime.xlsm (45.78 Ko)

Le 08/05/2017 à 17:50

bonjour

supprime la macro !

tu as un superbe tableau

as-tu songé à ajouter une colonne dite de pointage

= SI(jour=ferié ; 1 ; 0 )

ensuite un TCD ou des SOMMEPROD pour extraire les données de chacun de date à date.

Le 08/05/2017 à 18:23

Merci jmd mais je ne suis pas familier des TCD, pourrais tu m'aiguiller .Merci

Le 08/05/2017 à 18:50