
Sub Controle_Conso()

Application.ScreenUpdating = False
        
On Error Resume Next

Application.DisplayAlerts = False
Sheets("ALERTE").Delete
Sheets("Infos_OP").Delete
Application.DisplayAlerts = True

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''' MEF ENTETES ''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Rows(1)
    .RowHeight = 51.75
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = True
    .Replace What:="_", Replacement:=" ", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
    .AutoFilter
End With

Sheets("Sheet1").Range("A1").Select
    ActiveWindow.ScrollRow = Selection.Row
    ActiveWindow.ScrollColumn = Selection.Column
    ActiveWindow.SplitRow = 1
    ActiveWindow.FreezePanes = True


Columns.AutoFit

Application.ScreenUpdating = True
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''' RAPPORT MI ''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

Dim nb_conso, col_debut_mi As Integer, col_fin_mi As Integer, nb_mi As Integer, nb_lignes As Integer
Dim col_gencod_ho As Integer, col_gencod As Integer, col_rep_gencod As Integer, nb_gencod_ho As Integer, string_gencod As String
Dim col_enseigne_ho As Integer, col_enseigne As Integer, col_rep_enseigne As Integer, nb_enseigne_ho As Integer, string_enseigne As String
Dim col_achat_hp As Integer, col_date_tc As Integer, col_rep_achat As Integer, nb_achat_hp As Integer, string_achat_hp As String
Dim col_delai_depasse As Integer, col_cachet_poste As Integer, col_rep_delai As Integer, nb_delai_depasse As Integer, string_delai_depasse As String
Dim i As Integer, j As Integer
Dim DernConso As Long, DernOp As Integer

DernConso = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row

' Initialisation des variables globales de la macro
nb_conso = 0
col_debut_mi = 0
col_fin_mi = 0

col_gencod_ho = 0
col_gencod = 0
col_rep_gencod = 0
nb_gencod_ho = 0
string_gencod = "not null"

col_enseigne_ho = 0
col_enseigne = 0
col_rep_enseigne = 0
nb_enseigne_ho = 0
string_enseigne = "not null"

col_achat_hp = 0
col_date_tc = 0
col_rep_achat = 0
nb_achat_hp = 0
string_achat_hp = "not null"

col_delai_depasse = 0
col_cachet_poste = 0
col_rep_delai = 0
nb_delai_depasse = 0
string_delai_depasse = "not null"

' Rcupration du nombre de consos dans le fichier
For i = 2 To DernConso
        nb_conso = nb_conso + 1
Next i

Set DEBUTMI = Rows(1).Find("MONTANT A REMBOURSER AU CONSO", LookIn:=xlValues, LookAt:=xlWhole)
Set FINMI = Rows(1).Find("MI", LookIn:=xlValues, LookAt:=xlWhole)
Set HO = Rows(1).Find("MI GENCOD HORS OFFRE", LookIn:=xlValues, LookAt:=xlWhole)
Set HE = Rows(1).Find("MI HORS ENSEIGNES", LookIn:=xlValues, LookAt:=xlWhole)
Set HEO = Rows(1).Find("MI HORS ENSEIGNE OFFRE", LookIn:=xlValues, LookAt:=xlWhole)
Set HP = Rows(1).Find("MI ACHAT HORS PERIODE", LookIn:=xlValues, LookAt:=xlWhole)
Set DP = Rows(1).Find("MI DELAI DEPASSE CALENDAIRE", LookIn:=xlValues, LookAt:=xlWhole)
Set GC = Rows(1).Find("GENCOD", LookIn:=xlValues, LookAt:=xlWhole)
Set re = Rows(1).Find("REPORT ENSEIGNES", LookIn:=xlValues, LookAt:=xlWhole)
Set RS = Rows(1).Find("RAISON SOCIALE VETERINAIRE", LookIn:=xlValues, LookAt:=xlWhole)
Set ES = Rows(1).Find("ENSEIGNE", LookIn:=xlValues, LookAt:=xlWhole)
Set TC = Rows(1).Find("DATE TICKET CAISSE", LookIn:=xlValues, LookAt:=xlWhole)
Set CCHPST = Rows(1).Find("CACHET POSTE", LookIn:=xlValues, LookAt:=xlWhole)

    If Not DEBUTMI Is Nothing Then col_debut_mi = DEBUTMI.Column + 1
    If Not FINMI Is Nothing Then col_fin_mi = FINMI.Column - 1
    If Not HO Is Nothing Then
        col_gencod_ho = HO.Column
        string_gencod = "MI GENCOD HORS OFFRE"
    End If
    If Not HE Is Nothing Then
        col_enseigne_ho = HE.Column
        string_enseigne = "MI HORS ENSEIGNES"
    End If
    If Not HEO Is Nothing Then
        col_enseigne_ho = HEO.Column
        string_enseigne = "MI HORS ENSEIGNE OFFRE"
    End If
    If Not HP Is Nothing Then
        col_achat_hp = HP.Column
        string_achat_hp = "MI ACHAT HORS PERIODE"
    End If
    If Not DP Is Nothing Then
        col_delai_depasse = DP.Column
        string_delai_depasse = "MI DELAI DEPASSE CALENDAIRE"
    End If
    
    If Not GC Is Nothing Then col_gencod = GC.Column
    If Not re Is Nothing Then col_enseigne = re.Column
    If Not RS Is Nothing Then col_fin_mi = RS.Column
    If Not ES Is Nothing Then col_enseigne = ES.Column
    If Not TC Is Nothing Then col_date_tc = TC.Column
    If Not CCHPST Is Nothing Then col_cachet_poste = CCHPST.Column
    
' Colonnes de chaque catgorie pour le reporting
col_rep_gencod = 5
col_rep_enseigne = 8
col_rep_achat = 11
col_rep_delai = 14

' nb_lignes correspond  un nombre approximatif de MI pour cette OP. Ce nombre est >= a la ralit mais un tri est effectu en aval
nb_lignes = col_fin_mi - col_debut_mi

Sheets.add.Name = "Infos_OP"

    With Sheets("Infos_OP")
            .Range("A1").Value = "LISTE DES MI"
            .Range("B1").Value = "NB"
            .Range("C1").Value = "%"
            .Range("A1:C1").Interior.ColorIndex = 37
            
            .cells(1, col_rep_gencod).Value = "* GENCOD HORS OFFRE"
            .cells(1, col_rep_gencod + 1).Value = "NB"
            .cells(1, col_rep_gencod).Interior.ColorIndex = 37
            .cells(1, col_rep_gencod + 1).Interior.ColorIndex = 37
            
            .cells(1, col_rep_enseigne).Value = "** ENSEIGNES HORS OFFRE"
            .cells(1, col_rep_enseigne + 1).Value = "NB"
            .cells(1, col_rep_enseigne).Interior.ColorIndex = 37
            .cells(1, col_rep_enseigne + 1).Interior.ColorIndex = 37
                
            .cells(1, col_rep_achat).Value = "*** ACHAT HORS PERIODE"
            .cells(1, col_rep_achat + 1).Value = "NB"
            .cells(1, col_rep_achat).Interior.ColorIndex = 37
            .cells(1, col_rep_achat + 1).Interior.ColorIndex = 37
            
            .cells(1, col_rep_delai).Value = "**** DELAI DEPASSE (en jours)"
            .cells(1, col_rep_delai + 1).Value = "NB"
            .cells(1, col_rep_delai).Interior.ColorIndex = 37
            .cells(1, col_rep_delai + 1).Interior.ColorIndex = 37
                
            .Rows(1).RowHeight = 28.5
            .Rows(1).Font.Bold = True
            .Rows(1).WrapText = True
    End With
        
Dim a As Integer
Sheets("Sheet1").Activate
j = 2

 'On parcourt les colonnes de MI pour les dnombrer
    For a = col_debut_mi To (col_fin_mi + 1)
DernOp = Sheets("Infos_OP").Range("A" & Rows.Count).End(xlUp).Row + 1
        nb_mi = 0
        For i = 2 To DernConso
            If cells(i, col_debut_mi).Value = "1" Then
            nb_mi = nb_mi + 1
            End If
        Next i
        
        If nb_mi <> 0 Then
            Sheets("Infos_OP").cells(DernOp, 1).Value = Sheets("Sheet1").cells(1, col_debut_mi).Value        ' On effectue le reporting dans la nouvelle feuille
            Sheets("Infos_OP").cells(DernOp, 2).Value = nb_mi
        End If
    
        col_debut_mi = col_debut_mi + 1
        j = j + 1
    Next a

'Mise en forme
Sheets("Infos_OP").Activate
    For j = 2 To nb_lignes
        If cells(j, 1).Value = string_gencod Then
            cells(j, 1).Value = string_gencod & " *"
            cells(j, 2).Interior.ColorIndex = 45
            cells(j, 2).Font.Bold = True
            nb_gencod_ho = cells(j, 2).Value
        End If
        
        If cells(j, 1).Value = string_enseigne Then
            cells(j, 1).Value = string_enseigne & " **"
            cells(j, 2).Interior.ColorIndex = 50
            cells(j, 2).Font.Bold = True
            nb_enseigne_ho = cells(j, 2).Value
        End If
        
        If cells(j, 1).Value = string_achat_hp Then
            cells(j, 1).Value = string_achat_hp & " ***"
            cells(j, 2).Interior.ColorIndex = 17
            cells(j, 2).Font.Bold = True
            nb_achat_hp = cells(j, 2).Value
        End If
        
        If cells(j, 1).Value = string_delai_depasse Then
            cells(j, 1).Value = string_delai_depasse & " ****"
            cells(j, 2).Interior.ColorIndex = 15
            cells(j, 2).Font.Bold = True
            nb_delai_depasse = cells(j, 2).Value
        End If
    Next j
    
' On pure la liste des MI. On rpte la boucle 3 fois car avec les suppressions de lignes, le tri peut tre incomplet
    For j = 1 To 3
        For i = 2 To nb_lignes + 2
            If Left$(Sheets("Infos_OP").cells(i, 1).Value, 2) <> "MI" Then
                Sheets("Infos_OP").Rows(i).Delete
            End If
        Next
    Next

Sheets("Infos_OP").Range("A2:B50").Sort Key1:=Range("B2"), Order1:=xlDescending, Header:=xlNo   ' On classe les MI par occurences dcroissantes

DernOp = Sheets("Infos_OP").Range("A" & Rows.Count).End(xlUp).Row
nb_lignes = DernOp - 1

j = DernOp + 1

' Ajout de la ligne TOTAL
    With Sheets("Infos_OP")
            .cells(j, 1).Value = "TOTAL"
            .cells(j, 1).Font.Bold = True
            .cells(j, 2).Value = WorksheetFunction.Sum(Range("B2:B" & j))
            .cells(j, 2).Font.Bold = True
            .cells(j + 1, 1).Font.Bold = True
            .cells(j + 1, 2).Font.Bold = True
    End With

Sheets("Infos_OP").Range("C:C").NumberFormat = "0%"

j = 2
DernOp = Sheets("Infos_OP").Range("A" & Rows.Count).End(xlUp).Row - 1

        For j = 2 To DernOp
        DernOp = Sheets("Infos_OP").Range("A" & Rows.Count).End(xlUp).Row
            If cells(j, 2) <> 0 Then
                cells(j, 3) = cells(j, 2) / cells(DernOp, 2)
            End If
        DernOp = Sheets("Infos_OP").Range("A" & Rows.Count).End(xlUp).Row - 1
        Next j
    
    With Application.WorksheetFunction
        Sheets("Infos_OP").cells(j + 1, 1).Value = .CountIf(Sheets("Sheet1").Columns(col_fin_mi + 1), "[DOUBLONS]") & " doublon(s) dans ce fichier"
    End With

DernOp = Sheets("Infos_OP").Range("A" & Rows.Count).End(xlUp).Row - 1

    With Sheets("Infos_OP")
        .cells(DernOp, 3) = WorksheetFunction.Sum(Range("C2:C" & DernOp))
        .Range("A1:C" & DernOp).Borders.LineStyle = xlContinuous
        .Range("C2:C" & DernOp).Font.Italic = True
        .Range("A" & DernOp + 1 & ":C" & DernOp + 1).Borders(xlEdgeTop).LineStyle = xlDouble
        .cells(DernOp + 1, "E:F").Borders(xlEdgeTop).LineStyle = xlContinuous
    End With
    
i = 2
j = 2

Application.ScreenUpdating = True
''''''''''''''''''''''''''''''''''''''''''''
''''' TRAITEMENT DES GENCOD HO '''''
''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

' On vrifie le fait d'avoir effectivement une colonne MI GENCOD HORS OFFRE
' On passe au format texte. Indispensable sinon les GENCOD sont en criture scientifique

If col_gencod_ho <> 0 Then
     
    Sheets("Infos_OP").Columns(col_rep_gencod).NumberFormat = "@"
    
' On parcourt tout le fichier et on recopie les GENCOD dans la feuille Infos_OP, sans se soucier des doublons pour l'instant
    For i = 2 To nb_conso + 1
        If Sheets("Sheet1").cells(i, col_gencod_ho) = "1" Then
            Sheets("Infos_OP").cells(j, col_rep_gencod).Value = Sheets("Sheet1").cells(i, col_gencod).Value
            j = j + 1
        End If
    Next i
    
Sheets("Infos_OP").Activate

Dim DernGen As Long
DernGen = Sheets("Infos_OP").Range("E" & Rows.Count).End(xlUp).Row
    Range("E2:F" & DernGen).Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlNo

Dim cb_test As String, cb_plage As Range
Set cb_plage = Range("E2:E" & DernGen)

' Si des GENCOD sont en doublons, on crit leur quantit dans la cellule  droite mais SEULEMENT dans le premier GENCOD de ces doublons-l
    For i = 2 To DernGen
        With Application.WorksheetFunction
            If .CountIf(cb_plage, cells(i, col_rep_gencod)) > 1 And cells(i, col_rep_gencod) <> cb_test Then
                cells(i, col_rep_gencod + 1) = .CountIf(cb_plage, cells(i, col_rep_gencod))
            End If
            
            ' S'ils ne sont pas en doublons, on crit 1
            If .CountIf(cb_plage, cells(i, col_rep_gencod)) = 1 Then
                cells(i, col_rep_gencod + 1) = 1
            End If
        End With
        cb_test = cells(i, col_rep_gencod)
        
        ' S'il n'y a pas de quantit le GENCOD est un doublon dj prsent plus haut dans la liste on le supprime
        If IsEmpty(cells(i, col_rep_gencod + 1)) Then
            Range(cells(i, col_rep_gencod), cells(i, col_rep_gencod + 1)).ClearContents
        End If
    Next i
    
 ' On finit par classer les GENCOD par leur quantit dcroissante
    Sheets("Infos_OP").Range("E2:F500").Sort Key1:=Range("F2"), Order1:=xlDescending, Header:=xlNo

DernGen = Sheets("Infos_OP").Range("E" & Rows.Count).End(xlUp).Row + 1

' Ajout de la ligne Total
  With Sheets("Infos_OP")
        .cells(DernGen, col_rep_gencod).Value = "TOTAL"
        .cells(DernGen, col_rep_gencod).Font.Bold = True
        .cells(DernGen, col_rep_gencod + 1).Value = nb_gencod_ho
        .cells(DernGen, col_rep_gencod + 1).Interior.ColorIndex = 45
        .cells(DernGen, col_rep_gencod + 1).Font.Bold = True
        .Range("E1:F" & DernGen).Borders.Value = 1
  End With

End If

Application.ScreenUpdating = True
'''''''''''''''''''''''''''''''''''''''''''''''
''''' TRAITEMENT DES ENSEIGNES HO'''''
'''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

i = 2
j = 2

' On effectue exactement le mme traitement pour les enseignes !
If col_enseigne_ho <> 0 Then
    
    For i = 2 To nb_conso + 1
        If Sheets("Sheet1").cells(i, col_enseigne_ho) = "1" Then
            Sheets("Infos_OP").cells(j, col_rep_enseigne).Value = Sheets("Sheet1").cells(i, col_enseigne).Value
            j = j + 1
        End If
    Next i

Dim DernEns As Long
Sheets("Infos_OP").Activate
    DernEns = Sheets("Infos_OP").Range("H" & Rows.Count).End(xlUp).Row
    
    Range("H2:I" & DernEns).Sort Key1:=Range("H2"), Order1:=xlAscending, Header:=xlNo
    
Dim ens_test As String, ens_plage As Range
Set ens_plage = Range("H2:H" & DernEns)

    For i = 2 To DernEns
        With Application.WorksheetFunction
            If .CountIf(ens_plage, cells(i, col_rep_enseigne)) > 1 And cells(i, col_rep_enseigne) <> ens_test Then
                cells(i, col_rep_enseigne + 1) = .CountIf(ens_plage, cells(i, col_rep_enseigne))
            End If
            
            If .CountIf(ens_plage, cells(i, col_rep_enseigne)) = 1 Then
                cells(i, col_rep_enseigne + 1) = 1
            End If
        End With
        ens_test = cells(i, col_rep_enseigne)
        
        If IsEmpty(cells(i, col_rep_enseigne + 1)) Then
            Range(cells(i, col_rep_enseigne), cells(i, col_rep_enseigne + 1)).ClearContents
        End If
    Next i
    
    Range("H2:I" & DernEns).Sort Key1:=Range("I2"), Order1:=xlDescending, Header:=xlNo

DernEns = Sheets("Infos_OP").Range("H" & Rows.Count).End(xlUp).Row + 1

With Sheets("Infos_OP")
    .cells(DernEns, col_rep_enseigne).Value = "TOTAL"
    .cells(DernEns, col_rep_enseigne).Font.Bold = True
    .cells(DernEns, col_rep_enseigne + 1).Value = nb_enseigne_ho
    .cells(DernEns, col_rep_enseigne + 1).Interior.ColorIndex = 50
    .cells(DernEns, col_rep_enseigne + 1).Font.Bold = True
    .Range("H1:I" & DernEns).Borders.LineStyle = xlContinuous
    .cells(DernEns + 1, "H:I").Borders(xlEdgeTop).LineStyle = xlContinuous
End With

End If

Application.ScreenUpdating = True
''''''''''''''''''''''''''''''''''''''''''''''
''''' TRAITEMENT DES ACHATS HORS PERIODE '''''
''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

i = 2
j = 2

If col_achat_hp <> 0 Then
    Columns(col_rep_achat).NumberFormat = "dd/mm/yyyy"
    
    For i = 2 To nb_conso + 1
        If Sheets("Sheet1").cells(i, col_achat_hp) = "1" Then
            If IsEmpty(Sheets("Sheet1").cells(i, col_date_tc).Value) Then
                Sheets("Infos_OP").cells(j, col_rep_achat).Value = "(vide)"
            Else: Sheets("Infos_OP").cells(j, col_rep_achat).Value = DateValue(WorksheetFunction.Text(Sheets("Sheet1").cells(i, col_date_tc).Value, "mm/dd/yyyy"))
            End If
        j = j + 1
        End If
    Next i

Dim DernDat As Long
    DernDat = Sheets("Infos_OP").Range("K" & Rows.Count).End(xlUp).Row

    Range("K2:L" & DernDat).Sort Key1:=Range("K2"), Order1:=xlAscending, Header:=xlNo

Dim achat_test As String, achat_plage As Range
Set achat_plage = Sheets("Infos_OP").Range("K2:K" & j)

    For i = 2 To j
        With Application.WorksheetFunction
            If .CountIf(achat_plage, cells(i, col_rep_achat)) > 1 And cells(i, col_rep_achat) <> achat_test Then                                                                                                                                                                ' mais SEULEMENT dans la premire date de ces doublons-l
                cells(i, col_rep_achat + 1) = .CountIf(achat_plage, cells(i, col_rep_achat))
            End If
            If .CountIf(achat_plage, cells(i, col_rep_achat)) = 1 Then
             cells(i, col_rep_achat + 1).Value = 1
            End If
        End With
        achat_test = cells(i, col_rep_achat)
    
        If IsEmpty(cells(i, col_rep_achat + 1)) Then
            Range(cells(i, col_rep_achat), cells(i, col_rep_achat + 1)).ClearContents
        End If
    Next i
    
DernDat = Sheets("Infos_OP").Range("K" & Rows.Count).End(xlUp).Row
    Range("K2:L" & DernDat).Sort Key1:=Range("K2"), Order1:=xlAscending, Header:=xlNo
    
DernDat = Sheets("Infos_OP").Range("K" & Rows.Count).End(xlUp).Row + 1
 
    With Sheets("Infos_OP")
        .cells(DernDat, col_rep_achat).Value = "TOTAL"
        .cells(DernDat, col_rep_achat).Font.Bold = True
        .cells(DernDat, col_rep_achat + 1).Value = nb_achat_hp
        .cells(DernDat, col_rep_achat + 1).Interior.ColorIndex = 17
        .cells(DernDat, col_rep_achat + 1).Font.Bold = True
        .Range("K1:L" & DernDat).Borders.LineStyle = xlContinuous
        .cells(DernDat + 1, "K:L").Borders(xlEdgeTop).LineStyle = xlContinuous
    End With

End If

Application.ScreenUpdating = True
''''''''''''''''''''''''''''''''''''''''''''''''''
''''' TRAITEMENT DES DELAIS D'ENVOI DEPASSES '''''
''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

i = 2
j = 2

If col_delai_depasse <> 0 Then
     
    Columns(col_rep_delai).NumberFormat = "0"
    
    For i = 2 To nb_conso + 1
        If Sheets("Sheet1").cells(i, col_delai_depasse) = "1" Then
            If IsEmpty(Sheets("Sheet1").cells(i, col_cachet_poste)) Or IsEmpty(Sheets("Sheet1").cells(i, col_date_tc)) Then
                Sheets("Infos_OP").cells(j, col_rep_delai) = "(vide)"
                Else: Sheets("Infos_OP").cells(j, col_rep_delai) = DateDiff("d", CDate(Left$(Sheets("Sheet1").cells(i, col_date_tc).Value, 10)), CDate(Left$(Sheets("Sheet1").cells(i, col_cachet_poste).Value, 10)))
            End If
            j = j + 1
        End If
    Next i
    
Sheets("Infos_OP").Activate
Dim DernDl As Long
    DernDl = Sheets("Infos_OP").Range("N" & Rows.Count).End(xlUp).Row
    
    Range("N2:O" & DernDl).Sort Key1:=Range("N2"), Order1:=xlAscending, Header:=xlNo

Dim delai_test As String, delai_plage As Range
Set delai_plage = Sheets("Infos_OP").Range("N2:N" & DernDl)

    For i = 2 To j
        With Application.WorksheetFunction
            If .CountIf(delai_plage, cells(i, col_rep_delai)) > 1 And cells(i, col_rep_delai) <> delai_test Then                                                                                                                                                        ' mais SEULEMENT dans la premire date de ces doublons-l
                cells(i, col_rep_delai + 1) = .CountIf(delai_plage, cells(i, col_rep_delai))
            End If
                
            If .CountIf(delai_plage, cells(i, col_rep_delai)) = 1 Then
                cells(i, col_rep_delai + 1) = 1
            End If
        End With
     delai_test = cells(i, col_rep_delai)
     
            If IsEmpty(cells(i, col_rep_delai + 1)) Then
                Range(cells(i, col_rep_delai), cells(i, col_rep_delai + 1)).ClearContents
            End If
    Next i
    
DernDl = Sheets("Infos_OP").Range("N" & Rows.Count).End(xlUp).Row
    Range("N2:O" & DernDl).Sort Key1:=Range("N2"), Order1:=xlAscending, Header:=xlNo

DernDl = Sheets("Infos_OP").Range("N" & Rows.Count).End(xlUp).Row + 1

    With Sheets("Infos_OP")
        .cells(DernDl, col_rep_delai).Value = "TOTAL"                                  ' Ajout de la ligne Total
        .cells(DernDl, col_rep_delai).Font.Bold = True
        .cells(DernDl, col_rep_delai + 1).Value = nb_delai_depasse
        .cells(DernDl, col_rep_delai + 1).Interior.ColorIndex = 15
        .cells(DernDl, col_rep_delai + 1).Font.Bold = True
        .Range("N1:O" & DernDl).Borders.LineStyle = xlContinuous
    End With
End If

    With Sheets("Infos_OP")
        .Columns("A:P").AutoFit
        .Range("B:B,F:F,I:I,L:L,O:O").ColumnWidth = 5.71
        .Range("D:D,G:G,J:J,M:M").ColumnWidth = 2.86
        .Range("B:B,C:C,F:F,I:I,L:L,O:O").HorizontalAlignment = xlCenter
        .Range("B:B,C:C,F:F,I:I,L:L,O:O").VerticalAlignment = xlCenter
        .Columns("A:A").HorizontalAlignment = xlLeft
        .Columns("A:A").VerticalAlignment = xlCenter
    End With

' On supprime les reportings non concerns

    If IsEmpty(Sheets("Infos_OP").cells(3, col_rep_delai)) Then Range("N:O").Delete
    If IsEmpty(Sheets("Infos_OP").cells(3, col_rep_achat)) Then Range("K:M").Delete
    If IsEmpty(Sheets("Infos_OP").cells(3, col_rep_enseigne)) Then Range("H:J").Delete
    If IsEmpty(Sheets("Infos_OP").cells(3, col_rep_gencod)) Then Range("E:G").Delete

Application.ScreenUpdating = True
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''' ALERTE PARAMETRAGE ''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False


Dim ETAT As Range, ARTICLE As Range, MONTANTDEVISE As Range, MONTANT As Range, CODEUNIQUE As Range, ARTICLEWEB As Range, DOTATION As Range
Dim PRIME As Range, EPRIME As Range, IDCONSO As Range, DATEIMPRES As Range, IBAN As Range, BIC As Range, WEB As Range
Dim IDENTIFIANT As Range, NOMF As Range, PRENOM As Range, MODEPAIEMENT As Range
Dim DerLigne As Integer, DerCol As Integer
Dim e As Integer, F As Integer, k As Integer
Dim DerLigneConso As Integer, DerLigneConso2 As Integer

On Error Resume Next

Sheets("Sheet1").Activate

    DerLigne = Range("A" & Rows.Count).End(xlUp).Row
    Dern = DerLigne
    DerCol = cells(1, Columns.Count).End(xlToLeft).Column
    
' Declaration des colonnes
Set ETAT = Rows(1).Find("ETAT", LookIn:=xlValues, LookAt:=xlWhole)
Set ARTICLE = Rows(1).Find("ARTICLE", LookIn:=xlValues, LookAt:=xlWhole)
Set MONTANTDEVISE = Rows(1).Find("MONTANT REMB CONSO DEVISE", LookIn:=xlValues, LookAt:=xlWhole)
Set MONTANT = Rows(1).Find("MONTANT A REMBOURSER AU CONSO", LookIn:=xlValues, LookAt:=xlWhole)
Set CODEUNIQUE = Rows(1).Find("CODE UNIQUE", LookIn:=xlValues, LookAt:=xlWhole)
Set ARTICLEWEB = Rows(1).Find("ARTICLE WEB", LookIn:=xlValues, LookAt:=xlWhole)
Set DOTATION = Rows(1).Find("DOTATION", LookIn:=xlValues, LookAt:=xlWhole)
Set PRIME = Rows(1).Find("XXXXX", LookIn:=xlValues, LookAt:=xlWhole)
Set EPRIME = Rows(1).Find("XXXXX", LookIn:=xlValues, LookAt:=xlWhole)
Set IDCONSO = Rows(1).Find("CODE ID CONSO", LookIn:=xlValues, LookAt:=xlWhole)
Set DATEIMPRES = Rows(1).Find("DATE IMPRESSION", LookIn:=xlValues, LookAt:=xlWhole)
Set IBAN = Rows(1).Find("IBAN", LookIn:=xlValues, LookAt:=xlWhole)
Set BIC = Rows(1).Find("BIC", LookIn:=xlValues, LookAt:=xlWhole)
Set WEB = Rows(1).Find("*WEB*", LookIn:=xlValues, LookAt:=xlWhole)
Set MODEPAIEMENT = Rows(1).Find("mode paiement", LookIn:=xlValues, LookAt:=xlWhole)
Set IDENTIFIANT = Rows(1).Find("identifiant", LookIn:=xlValues, LookAt:=xlWhole)
Set NOMF = Rows(1).Find("NOM", LookIn:=xlValues, LookAt:=xlWhole)
Set PRENOM = Rows(1).Find("PRENOM", LookIn:=xlValues, LookAt:=xlWhole)

    If Not IDENTIFIANT Is Nothing Then ColID = IDENTIFIANT.Column Else ColID = Nothing
    If Not NOMF Is Nothing Then ColNO = NOMF.Column Else ColNO = col1
    If Not PRENOM Is Nothing Then ColPR = PRENOM.Column Else ColPR = col1
    If Not ETAT Is Nothing Then col1 = ETAT.Column Else col1 = Nothing
    If Not ARTICLE Is Nothing Then Col2 = ARTICLE.Column Else Col2 = col1
    If Not MONTANTDEVISE Is Nothing Then Col3 = MONTANTDEVISE.Column Else Col3 = col1
    If Not MONTANT Is Nothing Then Col4 = MONTANT.Column Else Col4 = col1
    If Not CODEUNIQUE Is Nothing Then Col5 = CODEUNIQUE.Column Else Col5 = col1
    If Not ARTICLEWEB Is Nothing Then Col6 = ARTICLEWEB.Column Else Col6 = col1
    If Not DOTATION Is Nothing Then Col7 = DOTATION.Column Else Col7 = col1
    If Not PRIME Is Nothing Then Col8 = PRIME.Column Else Col8 = col1
    If Not EPRIME Is Nothing Then Col9 = EPRIME.Column Else Col9 = col1
    If Not IDCONSO Is Nothing Then col10 = IDCONSO.Column Else col10 = col1
    If Not DATEIMPRES Is Nothing Then col11 = DATEIMPRES.Column Else col11 = col1
    If Not IBAN Is Nothing Then col12 = IBAN.Column Else col12 = col1
    If Not BIC Is Nothing Then col13 = BIC.Column Else col13 = col1
    If Not WEB Is Nothing Then col14 = WEB.Column Else col14 = col1
    If Not MODEPAIEMENT Is Nothing Then col15 = MODEPAIEMENT.Column Else col15 = col1

Sheets.add.Name = "ALERTE"

Application.ScreenUpdating = True
''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''' MONTANT A 0 OU ARTICLE VIDE ''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

Sheets("ALERTE").Activate
Range("A1").Value = "Alerte Taux : Valide => montant  Rembourser ou Montant  rembourser devise = 0.00"

'Recherche des montant  0 ou article vide..
Sheets("Sheet1").Activate
    For e = 2 To Dern
            If cells(e, col1) = "VALIDE" Then
                If cells(e, Col2) <> "" And cells(e, Col2) <> "VALIDE" Then
                    ElseIf cells(e, Col3) <> "0.00" And cells(e, Col3) <> "VALIDE" Then
                    ElseIf cells(e, Col4) <> "0.00" And cells(e, Col4) <> "VALIDE" Then
                    ElseIf cells(e, Col5) <> "" And cells(e, Col5) <> "VALIDE" Then
                    ElseIf cells(e, Col6) <> "0" And cells(e, Col6) <> "VALIDE" Then
                    ElseIf cells(e, Col7) <> "" And cells(e, Col7) <> "VALIDE" Then
                    ElseIf cells(e, Col8) <> "" And cells(e, Col8) <> "VALIDE" Then
                    ElseIf cells(e, Col9) <> "" And cells(e, Col9) <> "VALIDE" Then
                Else:
                NumL = "Montant  rembourse"
                Union(cells(1, ColID), cells(1, ColNO), cells(1, ColPR), cells(1, col1), cells(1, Col2), cells(1, Col3), cells(1, Col4), cells(1, Col5), cells(1, Col6), cells(1, Col7), cells(1, Col8), cells(1, Col9)).Copy
                Sheets("ALERTE").cells(2, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
                DerLigneConso = Sheets("ALERTE").Range("B" & Rows.Count).End(xlUp).Row
                Union(cells(e, ColID), cells(e, ColNO), cells(e, ColPR), cells(e, col1), cells(e, Col2), cells(e, Col3), cells(e, Col4), cells(e, Col5), cells(e, Col6), cells(e, Col7), cells(e, Col8), cells(e, Col9)).Copy
                Sheets("ALERTE").cells(DerLigneConso + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
                End If
            End If
    Next e

DerColConso = Sheets("ALERTE").cells(2, Columns.Count).End(xlToLeft).Column
    
'Mise en forme du tableau alerte
Sheets("ALERTE").Activate
            Range(cells(1, 1), cells(1, DerColConso)).MergeCells = True
            Range(cells(1, 1), cells(1, DerColConso)).EntireColumn.AutoFit
            Rows("2:2").RowHeight = 20.25
            Range(cells(1, 1), cells(DerLigneConso + 1, DerColConso)).Borders.Value = 1

                        With Range(cells(2, 1), cells(2, DerColConso))
                            .HorizontalAlignment = xlCenter
                            .VerticalAlignment = xlCenter
                            .ReadingOrder = xlContext
                            .Interior.ThemeColor = xlThemeColorDark2
                            .Interior.TintAndShade = -9.99786370433668E-02
                        End With

Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("A:A").ColumnWidth = 35

'Creation d'un lien qui renvoi  la bonne ligne en Sheet1
Dim Plage As Range, Valok As String, Valok2 As Range, Vallien As Integer
  
DerLigneConso = Sheets("ALERTE").Range("B" & Rows.Count).End(xlUp).Row
Set Plage = Sheets("Sheet1").Range("A2:A" & Dern)
      
    e = 0
    For e = 3 To DerLigneConso
        Valok = cells(e, 2).Value
        Set Valok2 = Plage.Find(Valok, LookIn:=xlValues, LookAt:=xlWhole)
            If Not Valok2 Is Nothing Then Vallien = Valok2.Row
        Sheets("ALERTE").Hyperlinks.add Anchor:=cells(e, 2), Address:="", SubAddress:="Sheet1!A" & Vallien, TextToDisplay:=""
    Next e

        If NumL <> "" Then
            MessageAlerte1 = "- Montant  rembourser" & Chr(10)
        Else:
            Message = "Pas d'erreur"
            Range("B1:B" & DerCol).EntireColumn.Delete
        End If
        
Application.ScreenUpdating = True
''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''' BOUTON MAIL ''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

'Cration des bouton envoyer mail et ne rien faire dans la feuil alerte
Sheets("ALERTE").Shapes.AddShape(msoShapeRectangle, 5.25, 15.75, 178.5, 17.25).Select
    With Selection
        .ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ShapeRange.Fill.ForeColor.Brightness = -0.0500000007
        .ShapeRange.Fill.Solid
        .ShapeRange.Line.ForeColor.Brightness = -0.0500000007
        .ShapeRange.TextFrame2.TextRange.Characters.Text = "Envoyer le mail"
        .ShapeRange.TextFrame2.TextRange.Characters(1, 15).ParagraphFormat.FirstLineIndent = 0
        .ShapeRange.TextFrame2.TextRange.Characters(1, 15).ParagraphFormat.Alignment = msoAlignCenter
        .ShapeRange.TextFrame2.TextRange.Characters(1, 15).Font.Fill.Visible = msoTrue
        .ShapeRange.TextFrame2.TextRange.Characters(1, 15).Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    End With
    
    Sheets("ALERTE").Shapes.Range(Array("Rectangle 1")).Select
    Selection.OnAction = "PERSONAL.XLSB!Envoyer_Email1"
    
Sheets("ALERTE").Shapes.AddShape(msoShapeRectangle, 5.25, 50.25, 178.5, 17.25).Select
    With Selection
        .ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ShapeRange.Fill.ForeColor.Brightness = -0.0500000007
        .ShapeRange.Fill.Solid
        .ShapeRange.Line.ForeColor.Brightness = -0.0500000007
        .ShapeRange.TextFrame2.TextRange.Characters.Text = "Ne rien faire"
        .ShapeRange.TextFrame2.TextRange.Characters(1, 13).ParagraphFormat.FirstLineIndent = 0
        .ShapeRange.TextFrame2.TextRange.Characters(1, 13).ParagraphFormat.Alignment = msoAlignCenter
        .ShapeRange.TextFrame2.TextRange.Characters(1, 13).Font.Fill.Visible = msoTrue
        .ShapeRange.TextFrame2.TextRange.Characters(1, 13).Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    End With
    
    Sheets("ALERTE").Shapes.Range(Array("Rectangle 2")).Select
    Selection.OnAction = "PERSONAL.XLSB!Ne_rien_faire"

Application.ScreenUpdating = True
'''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''' DATE IMPRESSION / CODE WEB '''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

Dim DerLigneConso3 As Integer, PremColConso As Integer, DerColConso2 As Integer

    DerColConso = Sheets("ALERTE").cells(2, Columns.Count).End(xlToLeft).Column
    PremColConso = DerColConso + 2
    DerColConso2 = Sheets("ALERTE").cells(2, Columns.Count).End(xlToLeft).Column
    DerLigneConso2 = Sheets("ALERTE").cells(Rows.Count, PremColConso).End(xlUp).Row
    
cells(1, PremColConso).Value = "Alerte Taux : ID conso => Date impression et/ ou code SI Web absent"

Sheets("Sheet1").Activate
            Union(cells(1, ColID), cells(1, ColNO), cells(1, ColPR), cells(1, col1), cells(1, col10), cells(1, col11), cells(1, col14)).Copy
            Sheets("ALERTE").cells(2, PremColConso).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
            
' Recherche des ID conso sans code web ou sans date impression
F = Rows
    For F = 2 To DerLigne
    Sheets("Sheet1").Activate
        If cells(F, col10) <> "" And cells(F, col10) <> cells(F, col1) Then
            If cells(F, col11) <> "" And cells(F, col11) <> cells(F, col1) Then
            Else:
                NumL2 = "Date impression ou code Web"
                Union(cells(F, ColID), cells(F, ColNO), cells(F, ColPR), cells(F, col1), cells(F, col10), cells(F, col11), cells(F, col14)).Copy
                    DerColConso2 = Sheets("ALERTE").cells(2, Columns.Count).End(xlToLeft).Column
                    DerLigneConso2 = Sheets("ALERTE").cells(Rows.Count, PremColConso).End(xlUp).Row
                    PremColConso = DerColConso + 2
                Sheets("ALERTE").cells(DerLigneConso2 + 1, PremColConso).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
            End If
       End If
    Next F

    For F = 2 To DerLigne
        If cells(F, col10) <> "" And cells(F, col10) <> cells(F, col1) Then
            If cells(F, col14) <> "" And cells(F, col14) <> cells(F, col1) Or cells(F, col14) = cells(F, col1) Then
            Else:
                NumL2 = "Date impression ou code Web"
                Union(cells(F, ColID), cells(F, ColNO), cells(F, ColPR), cells(F, col1), cells(F, col10), cells(F, col11), cells(F, col14)).Copy
                    DerColConso2 = Sheets("ALERTE").cells(2, Columns.Count).End(xlToLeft).Column
                    DerLigneConso2 = Sheets("ALERTE").cells(Rows.Count, PremColConso).End(xlUp).Row
                    PremColConso = DerColConso + 2
                Sheets("ALERTE").cells(DerLigneConso2 + 1, PremColConso).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
            End If
        End If
    Next F
    
' Mise en forme du tableau
Sheets("ALERTE").Activate
    DerColConso2 = Sheets("ALERTE").cells(2, Columns.Count).End(xlToLeft).Column
        
            Range(cells(1, PremColConso), cells(1, DerColConso2)).MergeCells = True
            Range(cells(1, PremColConso), cells(1, DerColConso2)).EntireColumn.AutoFit
            Rows("2:2").RowHeight = 20.25
            Range(cells(1, PremColConso), cells(DerLigneConso2 + 1, DerColConso2)).Borders.Value = 1

                        With Range(cells(2, PremColConso), cells(2, DerColConso2))
                            .HorizontalAlignment = xlCenter
                            .VerticalAlignment = xlCenter
                            .ReadingOrder = xlContext
                            .Interior.ThemeColor = xlThemeColorDark2
                            .Interior.TintAndShade = -9.99786370433668E-02
                        End With
    
    Sheets("ALERTE").Range(cells(2, PremColConso), cells(DerLigneConso2 + 1, DerColConso2)).RemoveDuplicates Columns:=1, Header:=xlYes

'Creation d'un lien qui renvoi  la bonne ligne en Sheet1
Dim Plage2 As Range, Valok3 As String, Valok4 As Range, Vallien2 As Integer
  
  DerLigneConso2 = Sheets("ALERTE").cells(Rows.Count, PremColConso).End(xlUp).Row
  Set Plage2 = Worksheets("Sheet1").Range("A2:A" & Dern)
      
e = 0
    For e = 3 To DerLigneConso2
        Valok3 = cells(e, PremColConso).Value
        Set Valok4 = Plage.Find(Valok3, LookIn:=xlValues, LookAt:=xlWhole)
            If Not Valok4 Is Nothing Then Vallien2 = Valok4.Row
        Sheets("ALERTE").Hyperlinks.add Anchor:=cells(e, PremColConso), Address:="", SubAddress:="Sheet1!A" & Vallien2, TextToDisplay:="Voir la ligne"
    Next e

        If NumL2 <> "" Then
            MessageAlerte2 = "- Date impression ou champ Web" & Chr(10)
        Else:
            Message = "Pas d'erreur"
            Range(cells(1, PremColConso), cells(DerLigneConso2, DerColConso2)).EntireColumn.Delete
        End If

Application.ScreenUpdating = True
'''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''' IBAN BIC VIDE '''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

Dim DerLigneConso4 As Integer, PremColConso2 As Integer, DerColConso3 As Integer

    DerColConso = Sheets("ALERTE").cells(2, Columns.Count).End(xlToLeft).Column
    PremColConso2 = DerColConso + 2
    DerColConso3 = Sheets("ALERTE").cells(2, Columns.Count).End(xlToLeft).Column
    DerLigneConso4 = Sheets("ALERTE").cells(Rows.Count, PremColConso).End(xlUp).Row
    
cells(1, PremColConso2).Value = "Alerte Taux : ID conso => IBAN et BIC vide"

'Recherche les iban et bic vide si le mode de paiement n'est pas LC (=Lettre chque)
Sheets("Sheet1").Activate
            Union(cells(1, ColID), cells(1, ColNO), cells(1, ColPR), cells(1, col1), cells(1, col10), cells(1, col15), cells(1, col12), cells(1, col13)).Copy
            Sheets("ALERTE").cells(2, PremColConso2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False

        For k = 2 To Dern
                If cells(k, col10) <> "" And cells(k, col10).Value <> cells(k, col1).Value Then
                    If cells(k, col15) <> "LC" And cells(k, col15).Value <> cells(k, col1).Value Then
                        If cells(k, col12) <> "" And cells(k, col12).Value <> cells(k, col1).Value And cells(k, col13) <> "" And cells(k, col13).Value <> cells(k, col1).Value Then
                        Else:
                            NumL3 = "IBAN et BIC"
                            
                            DerLigneConso4 = Sheets("ALERTE").Range("B" & Rows.Count).End(xlUp).Row
                            DerColConso3 = Sheets("ALERTE").cells(2, Columns.Count).End(xlToLeft).Column
                            
                            Union(cells(k, ColID), cells(k, ColNO), cells(k, ColPR), cells(k, col1), cells(k, col10), cells(k, col15), cells(k, col12), cells(k, col13)).Copy
                                DerColConso3 = Sheets("ALERTE").cells(2, Columns.Count).End(xlToLeft).Column
                                DerLigneConso4 = Sheets("ALERTE").cells(Rows.Count, PremColConso2).End(xlUp).Row
                                PremColConso2 = DerColConso + 2
                            Sheets("ALERTE").cells(DerLigneConso4 + 1, PremColConso2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
                        End If
                    End If
                End If
        Next k

'Mise en forme du tableau
Sheets("ALERTE").Activate
        DerColConso3 = Sheets("ALERTE").cells(2, Columns.Count).End(xlToLeft).Column
        
            Range(cells(1, PremColConso2), cells(1, DerColConso3)).MergeCells = True
            Range(cells(1, PremColConso2), cells(1, DerColConso3)).EntireColumn.AutoFit
            Rows("2:2").RowHeight = 20.25
            Range(cells(1, PremColConso2), cells(DerLigneConso4 + 1, DerColConso3)).Borders.Value = 1

                        With Range(cells(2, PremColConso2), cells(2, DerColConso3))
                            .HorizontalAlignment = xlCenter
                            .VerticalAlignment = xlCenter
                            .ReadingOrder = xlContext
                            .Interior.ThemeColor = xlThemeColorDark2
                            .Interior.TintAndShade = -9.99786370433668E-02
                        End With
                   
'Creation d'un lien qui renvoi  la bonne ligne en Sheet1
Dim Plage3 As Range, Valok6 As String, Valok7 As Range, Vallien3 As Integer

    DerLigneConso4 = Sheets("ALERTE").cells(Rows.Count, PremColConso2).End(xlUp).Row
    Set Plage3 = Worksheets("Sheet1").Range("A2:A" & Dern)
      
e = 0
    For e = 3 To DerLigneConso4
        Valok6 = cells(e, PremColConso2).Value
        Set Valok7 = Plage.Find(Valok6, LookIn:=xlValues, LookAt:=xlWhole)
            If Not Valok7 Is Nothing Then Vallien3 = Valok7.Row
        Sheets("ALERTE").Hyperlinks.add Anchor:=cells(e, PremColConso2), Address:="", SubAddress:="Sheet1!A" & Vallien3, TextToDisplay:="Voir la ligne"
    Next e

        If NumL3 <> "" Then
            MessageAlerte3 = "- IBAN et BIC vide" & Chr(10)
        Else:
            Message = "Pas d'erreur"
            Range(cells(1, PremColConso2), cells(DerLigneConso4, DerColConso3)).EntireColumn.Delete
        End If
        
Application.ScreenUpdating = True
''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''' AJOUT BOUTON MAIL INFOS OP '''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

Sheets("Infos_OP").Activate

Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("B:B").ColumnWidth = 2
Columns("A:A").ColumnWidth = 50

With cells(1, 1)
    .Value = "Choisissez l'objet du mail"
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlCenter
    .Interior.ThemeColor = xlThemeColorLight2
    .Interior.TintAndShade = 0.799981688894314
End With

Range("A3:A4").MergeCells = True
Range("A1:A4").Borders.LineStyle = xlContinuous

Sheets("Infos_OP").Shapes.AddShape(msoShapeRectangle, 132, 5, 120.5, 20).Select
    With Selection
        .ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ShapeRange.Fill.ForeColor.Brightness = -0.0500000007
        .ShapeRange.Fill.Solid
        .ShapeRange.Line.ForeColor.Brightness = -0.0500000007
        .ShapeRange.TextFrame2.TextRange.Characters.Text = "ICI"
        .ShapeRange.TextFrame2.TextRange.Characters(1, 3).ParagraphFormat.FirstLineIndent = 0
        .ShapeRange.TextFrame2.TextRange.Characters(1, 3).ParagraphFormat.Alignment = msoAlignCenter
        .ShapeRange.TextFrame2.TextRange.Characters(1, 3).Font.Fill.Visible = msoTrue
        .ShapeRange.TextFrame2.TextRange.Characters(1, 3).Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    End With
    
    Sheets("Infos_OP").Shapes.Range(Array("Rectangle 3")).Select
    Selection.OnAction = "PERSONAL.XLSB!Choix_Objet"

Sheets("Infos_OP").Shapes.AddShape(msoShapeRectangle, 10, 50.25, 250, 17.25).Select
    With Selection
        .ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ShapeRange.Fill.ForeColor.Brightness = -0.0500000007
        .ShapeRange.Fill.Solid
        .ShapeRange.Line.ForeColor.Brightness = -0.0500000007
        .ShapeRange.TextFrame2.TextRange.Characters.Text = "Envoyer le mail"
        .ShapeRange.TextFrame2.TextRange.Characters(1, 15).ParagraphFormat.FirstLineIndent = 0
        .ShapeRange.TextFrame2.TextRange.Characters(1, 15).ParagraphFormat.Alignment = msoAlignCenter
        .ShapeRange.TextFrame2.TextRange.Characters(1, 15).Font.Fill.Visible = msoTrue
        .ShapeRange.TextFrame2.TextRange.Characters(1, 15).Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
    End With
    
    Sheets("Infos_OP").Shapes.Range(Array("Rectangle 4")).Select
    Selection.OnAction = "PERSONAL.XLSB!Envoyer_Email2"
    Range("C2").Select
    
Application.DisplayAlerts = False
'Message box d'alerte
    If NumL = "" And NumL2 = "" And NumL3 = "" Then
        msgbox "Pas d'erreur"
        Sheets("ALERTE").Delete
        Sheets("Infos_OP").Activate
        Application.ScreenUpdating = True
            With Objet_Mail
              .Show 0 'non modal
              .Left = 650
              .Top = 350
            End With
        Application.ScreenUpdating = False
    Else:
        msgbox ("Alerte Taux : " & Chr(10) & MessageAlerte1 & MessageAlerte2 & MessageAlerte3)
        Sheets("ALERTE").Activate
    End If
Application.DisplayAlerts = True

    On Error GoTo ProcedureErreur
 
    Dim TablePivot As PivotTable
    Dim feuille As Worksheet
   
    For Each feuille In ActiveWorkbook.Worksheets
        For Each TablePivot In feuille.PivotTables
            With TablePivot.PivotCache
                .MissingItemsLimit = xlMissingItemsNone
                .Refresh
            End With
        Next TablePivot
    Next feuille
    
    Set TablePivot = Nothing
    Set feuille = Nothing
Exit Sub
 
ProcedureErreur:
    msgbox "Une erreur est survenue..."

Application.ScreenUpdating = True

End Sub

Sub Envoyer_Email1()

Application.ScreenUpdating = False

 'On Error Resume Next
 On Error GoTo Err1

    Dim FileExtStr As String, FileFormatNum As Long, Sourcewb As Workbook, Destwb As Workbook
    Dim TempFilePath As String, TempFileName As String, rngMI As Range
    Dim StrBody As String, StrBody1 As String, StrBody1a As String, StrBody2 As String
    Dim StrBody2a As String, StrBody3 As String, StrBodyA As String, StrBodyB As String, StrBodyC As String, i As Integer
    Dim NOMOP As Range, ALERTE1 As String, ALERTE2 As String, ALERTE3 As String, chaine As String
    Dim colone1 As Long, ligne1 As Long
    
'Rcup num OP

Sheets("Sheet1").Activate
Set NOMOP = Rows(1).Find("NOMOP", LookIn:=xlValues, LookAt:=xlWhole)
If Not NOMOP Is Nothing Then COLNOMOP = NOMOP.Column
chaine = cells(2, COLNOMOP)

NUMOP = Val(chaine)
    
    If Len(NUMOP) = 4 Then
        NUMOP = "0" & NUMOP
    End If
    
    If Len(NUMOP) = 3 Then
        NUMOP = "00" & NUMOP
    End If
    
    If Len(NUMOP) = 6 Then
        NUMOP = Mid(NUMOP, 2, 5)
    End If

Sheets("Infos_OP").Activate
Sheets("Infos_OP").Range("A:B").Delete
colone1 = Sheets("Infos_OP").cells(1, Columns.Count).End(xlToLeft).Column
ligne1 = Sheets("Infos_OP").UsedRange.Rows.Count + 1
Set rngMI = Sheets("Infos_OP").Range(cells(1, 1), cells(ligne1, colone1))

' cherche si les feuilles existent
For i = 1 To Worksheets.Count
    If Worksheets(i).Name = "Infos_OP" Then
        Set rngMI = Sheets("Infos_OP").Range(cells(1, 1), cells(ligne1, colone1))
    Else
    End If
    If Worksheets(i).Name = "ALERTE" Then
        Set rngAL = Sheets("ALERTE").UsedRange
    Else
    End If
Next i

' dfinis la phrase d'alerte en fonction des tableau en feuille ALERTE
Sheets("ALERTE").Activate
Set MONTANT = Rows(1).Find("Alerte Taux : Valide => montant  Rembourser ou Montant  rembourser devise = 0.00", LookIn:=xlValues, LookAt:=xlWhole)
Set DATEIM = Rows(1).Find("Alerte Taux : ID conso => Date impression et/ ou code SI Web absent", LookIn:=xlValues, LookAt:=xlWhole)
Set IBANB = Rows(1).Find("Alerte Taux : ID conso => IBAN et BIC vide", LookIn:=xlValues, LookAt:=xlWhole)

If Not MONTANT Is Nothing Then
ALERTE1 = "Alerte Taux merci de votre intervention et retour"
Else: ALERTE1 = ""
End If

If Not DATEIM Is Nothing Then
ALERTE2 = "Alerte Taux merci de votre intervention et retour"
Else: ALERTE2 = ""
End If

If Not IBANB Is Nothing Then
ALERTE3 = "Alerte Taux "
Else: ALERTE3 = ""
End If

' Les diffrents corps du mail

        StrBody = "<BODY style=font-size:11pt;font-family:Calibri>Bonjour, " & "<br>" & "<br>"
        
        StrBody1 = "<BODY style=font-size:11pt;font-family:Calibri>Pour information [...] tu trouveras ci-dessous et en PJ les divers lments relatifs  savoir :" & "<br>" & "<br>" & _
        "<B><I><U>A/Extraction du rapport :</B></I></U>" & "<br>" & "<br></BODY>"
        StrBody1a = "<BODY style=font-size:11pt;font-family:Calibri><blockquote>Rpartition exhaustive des MI prsents dans le fichier " & " </blockquote></BODY>"
        
        If ALERTE1 <> "" Then
        StrBodyA = "<BODY style=font-size:11pt;font-family:Calibri> <FONT COLOR=red><B>Attention [...] merci de votre intervention et retour</FONT></B>" & "<br>" & "<br>"
        Else: StrBodyA = ""
        End If
        If ALERTE2 <> "" Then
        StrBodyB = "<BODY style=font-size:11pt;font-family:Calibri> <FONT COLOR=red><B>Attention [...] merci de votre intervention et retour</FONT></B>" & "<br>" & "<br>"
        Else: StrBodyB = ""
        End If
        If ALERTE3 <> "" Then
        StrBodyC = "<BODY style=font-size:11pt;font-family:Calibri> <FONT COLOR=red><B>Attention [...] merci de votre intervention et retour</FONT></B>" & "<br>" & "<br>"
        Else: StrBodyC = ""
        End If
        
        StrBody2 = "<BODY style=font-size:11pt;font-family:Calibri><B><I><U>B/ Extraction [...] fichier :</B></I></U></BODY>" & "<br>"
        StrBody2a = "<BODY style=font-size:11pt;font-family:Calibri><blockquote>Tu trouveras en PJ l'extraction.</blockquote></BODY>" & "<br>"
        StrBody3 = "<BODY style=font-size:11pt;font-family:Calibri>Retour obligatoire, ce jour avant <B>16 H 30</B>." & "<br>" & "<br>" & "Cordialement," & "</BODY>"

'Le mail

    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

Application.ScreenUpdating = True
Application.ScreenUpdating = False
With OutMail
        .Display
        .To = ""                  '*******************************DESTINATAIRE*********************************
        .CC = "" 
        .BCC = ""
        .Subject = NUMOP & " - Alerte Paramtrage - Export du " & Format(Now, "yyyy mm dd")
        .HTMLBody = StrBody & StrBodyA & StrBodyB & StrBodyC & StrBody1 & StrBody1a & "<blockquote>" & RangetoHTML(rngMI) & "</blockquote>" & StrBody2 & StrBody2a & StrBody3 & .HTMLBody
        
        Application.DisplayAlerts = False
            Sheets("Infos_OP").Delete
            Sheets("Alerte").Range("A:A").Delete
        Application.DisplayAlerts = True
            Set Sourcewb = ActiveWorkbook
            Set rng = Nothing
            Set rng = Sheets("Sheet1").UsedRange
            Set Destwb = ActiveWorkbook
            Sheets("Sheet1").Select
            
            ' Determine la version dexcel et lextention du fichier
            With Destwb
                If Val(Application.Version) < 12 Then
                    ' Vous utilisez Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    ' Vous utilisez Excel 2007-2016
                    Select Case Sourcewb.FileFormat
                    Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                    Case 52:
                        If .HasVBProject Then
                            FileExtStr = ".xlsm": FileFormatNum = 52
                        Else
                            FileExtStr = ".xlsx": FileFormatNum = 51
                        End If
                    Case 56: FileExtStr = ".xls": FileFormatNum = 56
                    Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                    End Select
                End If
            End With
            
            TempFilePath = Environ$("temp") & "\"
            TempFileName = NUMOP & " - " & Sourcewb.Name
            
Application.DisplayAlerts = False
                Destwb.SaveAs TempFilePath & TempFileName '& FileExtStr, FileFormat:=FileFormatNum
Application.DisplayAlerts = True

        .Attachments.add Destwb.FullName
End With

Application.ScreenUpdating = True

Application.DisplayAlerts = False
    Destwb.Close savechanges:=False
Application.DisplayAlerts = True

Kill TempFilePath & TempFileName


Exit Sub
Err1:
msgbox "Erreur" & Err.Number & "Erreur Envoyer_Email1"


End Sub

Function RangetoHTML(ByVal rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
 'On Error Resume Next
  On Error GoTo Err3
 
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.add(1)
    With TempWB.Sheets(1)
 
        .cells(1).PasteSpecial Paste:=8
        .cells(1).PasteSpecial xlPasteValues, , False, False
        .cells(1).PasteSpecial xlPasteFormats, , False, False
        .cells(1).Select
      
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        'On Error GoTo 0
    End With
 
    With TempWB.PublishObjects.add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
Application.DisplayAlerts = False
    TempWB.Close savechanges:=False
    Kill TempFile
Application.DisplayAlerts = True
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
    
Exit Function
Err3:
msgbox "Erreur" & Err.Number & "Erreur RangeHTML"
 
End Function

Sub Ne_rien_faire()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

ActiveSheet.Delete
Sheets("Infos_OP").Activate

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Sub Choix_Objet()

            With Objet_Mail
              .Show 0 
              .Left = 650
              .Top = 350
            End With

End Sub

Sub Envoyer_Email2()

Application.ScreenUpdating = False

 'On Error Resume Next
  On Error GoTo Err1

    Dim FileExtStr As String, FileFormatNum As Long, Sourcewb As Workbook, Destwb As Workbook
    Dim TempFilePath As String, TempFileName As String, rngMI As Range
    Dim StrBody As String, StrBody1a As String, StrBody2 As String, StrBody2a As String, StrBody3 As String
    Dim i As Integer, colone1 As Long, ligne1 As Long, NOMOP As Range, chaine As String
    
'Rcup num OP

Sheets("Sheet1").Activate
Set NOMOP = Rows(1).Find("NOMOP", LookIn:=xlValues, LookAt:=xlWhole)
If Not NOMOP Is Nothing Then COLNOMOP = NOMOP.Column
chaine = cells(2, COLNOMOP)

NUMOP = Val(chaine)

    If Len(NUMOP) = 4 Then
        NUMOP = "0" & NUMOP
    End If
    
    If Len(NUMOP) = 3 Then
        NUMOP = "00" & NUMOP
    End If
    
    If Len(NUMOP) = 6 Then
        NUMOP = Mid(NUMOP, 2, 5)
    End If
    
Sheets("Infos_OP").Activate
    If Range("A2") <> "" Then
        Objet = Sheets("Infos_OP").Range("A2").Value
    Else:
        msgbox ("Vous n'avez pas slectionn l'objet !")
    Exit Sub
    End If
    
' cherche si les feuilles existent
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = "ALERTE" Then
            If msgbox("Attention l'onglet Alerte est encore existant. Voulez-vous quand mme envoyer le mail ?", vbYesNo, "Demande de confirmation") = vbNo Then
            Exit Sub
            Else
            End If
        End If
    Next i
    For i = 1 To Worksheets.Count
        If Worksheets(i).Name = "Infos_OP" Then
            Sheets("Infos_OP").Range("A:B").Delete
            colone1 = Sheets("Infos_OP").cells(1, Columns.Count).End(xlToLeft).Column
            ligne1 = Sheets("Infos_OP").UsedRange.Rows.Count + 1
            Set rngMI = Sheets("Infos_OP").Range(cells(1, 1), cells(ligne1, colone1))
        Else
        End If
    Next i
    
' Les diffrents corps du mail

        StrBody = "<BODY style=font-size:11pt;font-family:Calibri>Bonjour, " & "<br>" & "<br>" & _
        "Pour information [...] tu trouveras ci-dessous et en PJ les divers lments relatifs  savoir :" & "<br>" & "<br>" & _
        "<B><I><U>A/Extraction du rapport :</B></I></U>" & "<br>" & "<br></BODY>"
        StrBody1a = "<BODY style=font-size:11pt;font-family:Calibri><blockquote>Rpartition exhaustive des MI prsents dans le fichier:" & " </blockquote></BODY>"

        StrBody2 = "<BODY style=font-size:11pt;font-family:Calibri><B><I><U>B/ Extraction  [...] fichier :</B></I></U></BODY>" & "<br>"
        StrBody2a = "<BODY style=font-size:11pt;font-family:Calibri><blockquote>Tu trouveras en PJ l'extraction </blockquote></BODY>" & "<br>"
        StrBody3 = "<BODY style=font-size:11pt;font-family:Calibri>Retour obligatoire, ce jour avant <B>16 H 30</B>." & "<br>" & "<br>" & "Cordialement," & "</BODY>"

'Le mail

    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

Application.ScreenUpdating = True
Application.ScreenUpdating = False

With OutMail
        .Display
        .To = ""              '*******************************DESTINATAIRE*********************************
        .CC = ""
        .BCC = ""
        .Subject = NUMOP & " - " & Objet & " - Export du " & Format(Now, "yyyy mm dd")
        .HTMLBody = StrBody & StrBody1a & "<blockquote>" & RangetoHTML(rngMI) & "</blockquote>" & StrBody2 & StrBody2a & StrBody3 & .HTMLBody
        
        
        Application.DisplayAlerts = False
        With Workbook
            On Error Resume Next
            .Sheets("Infos_OP").Delete
            .Sheets("Alerte").Delete
        End With
        Application.DisplayAlerts = True
        
            Set Sourcewb = ActiveWorkbook
            Set rng = Nothing
            Set rng = Sheets("Sheet1").UsedRange
            Set Destwb = ActiveWorkbook
            Sheets("Sheet1").Select
            
            ' Determine la version dexcel et lextention du fichier
            With Destwb
                If Val(Application.Version) < 12 Then
                    ' Vous utilisez Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    ' Vous utilisez Excel 2007-2016
                    Select Case Sourcewb.FileFormat
                    Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                    Case 52:
                        If .HasVBProject Then
                            FileExtStr = ".xlsm": FileFormatNum = 52
                        Else
                            FileExtStr = ".xlsx": FileFormatNum = 51
                        End If
                    Case 56: FileExtStr = ".xls": FileFormatNum = 56
                    Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                    End Select
                End If
            End With
            
            TempFilePath = Environ$("temp") & "\"
            TempFileName = NUMOP & " - " & Sourcewb.Name
            
Application.DisplayAlerts = False
       Destwb.SaveAs TempFilePath & TempFileName '& FileExtStr, FileFormat:=FileFormatNum
Application.DisplayAlerts = True

        .Attachments.add Destwb.FullName
End With

Application.ScreenUpdating = True

Application.DisplayAlerts = False
    Destwb.Close savechanges:=False
Application.DisplayAlerts = True

Kill TempFilePath & TempFileName


Exit Sub
Err1:
msgbox "Erreur" & Err.Number & "Erreur Envoyer_Email2"

End Sub


