Aide formule à alléger

Sub test()
Application.ScreenUpdating = False
Nlig = Feuil7.Range("A" & Rows.Count).End(xlUp).Row
   For L = 2 To Nlig
      Uf = Feuil7.Range("F" & L).Value
      Depense = Feuil7.Range("E" & L).Value
      Mois = Feuil7.Range("D" & L).Value
      Compte = Feuil7.Range("B" & L).Text
      Col = Mois + 2
      Sheets("UF " & Uf).Select
         For L1 = 8 To 239
            If Range("A" & L1).Text = Compte Then
               Cells(L1, Col).Value = Depense
            End If
         Next
   Next
End Sub

Lettre
Compte
Exercice
Mois
Uf
Depense
Pole
Site

Sub test()
Dim Uf As String
Dim Compte As String
Application.ScreenUpdating = False
Nlig = Feuil7.Range("A" & Rows.Count).End(xlUp).Row
   For L = 2 To Nlig
      Uf = Feuil7.Range("F" & L).Text
      Depense = Feuil7.Range("E" & L).Value
      Mois = Feuil7.Range("D" & L).Value
      Compte = Feuil7.Range("B" & L).Text
      Col = Mois + 2
      Sheets("UF " & Uf).Select
         For L1 = 8 To 239
            If Range("A" & L1).Text = Compte Then
               Cells(L1, Col).Value = Depense
            End If
         Next
   Next
End Sub

Option Explicit
'Il faut activer la référence "Microsoft Outlook XX.0 Object Library"

'Déclaration des variables de portée "modulaire" (utilisées dans plusieurs fonctions)
Dim DonneesGlobales() As Variant
Dim DicoUfTxt As Object
Dim DicoCptes As Object
Dim DicoUfFeuil As Object
Dim DicoPoles As Object
Dim Sommes() As Double
Dim CodeErreur As Byte
Dim Temps, TpsMails

'********************************************************************************************************************************************

Sub Principale()
'Sub servant à lancer toutes les fonctions, dans l'ordre.
Dim Elem As Variant
Dim Chemin As String, Racine As String, ChemTxt As String, Recap As String
Dim Mois As Integer, Annee As Integer
Dim Nb As Long
Dim AppOutlk As New Outlook.Application

    'Vérifie, avant de lancer le bouzin, qu'Outlook est ouvert
    Set AppOutlk = New Outlook.Application
    If AppOutlk.Explorers.Count = 0 Then
        MsgBox "Merci d'ouvrir votre messagerie Outlook.": Exit Sub
    End If
    
    Application.ScreenUpdating = False
    'Initialisation des variables
    If InitVariables(ThisWorkbook, Chemin, Racine, ChemTxt, Mois, Annee) = False Then MsgBox MsgErreur, vbInformation: Exit Sub
    'Création du répertoire (ex : UF's  10 2014 21_01_2015 12_05) ou stocker tous les fichiers (ex : UF_3211 10_2014.xls)
    If CreationRepertoire(Chemin) = False Then MsgBox MsgErreur(Chemin), vbInformation: Exit Sub
    'collecte les données du fichier txt
    DonneesGlobales = CollectDonnees(ChemTxt)
    If CodeErreur > 0 Then MsgBox MsgErreur, vbInformation: Exit Sub
    'boucle sur tous les UF
    For Each Elem In DicoUfTxt.Keys
        'Dimensionnement de la variable tableau Sommes
        Sommes = DimSommes(DicoCptes.Count)
        If CodeErreur > 0 Then MsgBox MsgErreur, vbInformation: Exit Sub
        'calcule la somme de l'UF en cours, par compte, pour le mois et l'année donnée
        If CalculSommesParComptes(Elem, Mois, Annee) = False Then MsgBox MsgErreur, vbInformation: Exit Sub
        'efface les données de la feuille UF
        If ClearRange(QuelRange(Sheets("UF"))) = False Then MsgBox MsgErreur, vbInformation: Exit Sub
        'remplit la feuille UF
        If RempliUF(Sheets("UF")) = False Then MsgBox MsgErreur, vbInformation: Exit Sub
        'Crée, enregistre et ferme le classeur (ex : UF_3211 10_2014.xls)
        If CreeClasseurs(Sheets("UF"), Chemin, Elem, Mois, Annee, ThisWorkbook, CStr(Split(DicoUfFeuil(Elem), "¤")(0))) = False Then MsgBox MsgErreur("UF " & Elem & " " & Mois & " " & Annee), vbInformation: Exit Sub
    Next
    If EnvoiMails(ThisWorkbook.Name, Chemin, Mois, Annee) = False Then MsgBox MsgErreur, vbInformation
    Application.ScreenUpdating = True
    
End Sub

'********************************************************************************************************************************************

Function InitVariables(Wbk As Workbook, Chem As String, Rac As String, RacTxt As String, intMois As Integer, intAnnee As Integer) As Boolean
'Initialise les variables (entre parenthèses, leurs noms dans les paramètres de la fonction) :
    '- Chemin (Chem) : accès complet au répertoire qui sera créé pour stocker les fichiers UF's
    '- Racine (Rac) : accès complet au répertoire de ce classeur (pour y créer le sous-répertoire Chemin)
    '- RacineTxt (RacTxt) : chemin complet d'accès au fichier txt
    '- Mois (intMois) : Mois maxi
    '- Annee (intAnnee) : Année choisie
Dim Sep As String, maVar As Variant, Cpt As Integer

    On Error GoTo Fin
    CodeErreur = 0
    Sep = Application.International(xlDecimalSeparator)
    Cpt = 0
    Do
        Cpt = Cpt + 1
        If Cpt = 4 Then GoTo Fin
        maVar = Application.InputBox("Mois (saisir un nombre entre 1 et 12) : ", "Saisie du mois", Type:=1)
        If maVar < 1 Or maVar > 12 Then
            MsgBox "Saisir un nombre entre 1 et 12."
        ElseIf InStr(maVar, Sep) > 0 Then
            MsgBox "Saisir un nombre entier."
        Else
            intMois = maVar
            Exit Do
        End If
    Loop
    Cpt = 0
    Do
        Cpt = Cpt + 1
        If Cpt = 4 Then GoTo Fin
        maVar = Application.InputBox("Année (saisir un nombre entre 1900 et 2100) : ", "Saisie de l'année", Type:=1)
        If maVar < 1900 Or maVar > 2100 Then
            MsgBox "Saisir un nombre entre 1900 et 2100."
        ElseIf InStr(maVar, Sep) > 0 Then
            MsgBox "Saisir un nombre entier."
        Else
            intAnnee = maVar
            Exit Do
        End If
    Loop
    MsgBox "La prochaine boîte de dialogue vous invite à choisir le fichier txt à importer."
    RacTxt = Application.GetOpenFilename("Fichiers txt, *.txt")
    If RacTxt = "Faux" Then GoTo Fin
    With Wbk
        Rac = .Path & "\"
    End With
    Chem = Rac & "UF's " & intMois & " " & intAnnee & " " & Format(Now, "dd_mm_yyyy hh_mm")
    InitVariables = True: Exit Function
Fin:
    InitVariables = False: CodeErreur = 1
End Function

'********************************************************************************************************************************************

Function CreationRepertoire(Chem As String) As Boolean
'Fonction créant le répertoire de sauvegarde des fichiers UF's

    On Error GoTo Fin
    If Dir(Chem, 16) = "" Then MkDir Chem
    CreationRepertoire = True: Exit Function
Fin:
    CreationRepertoire = False: CodeErreur = 2
End Function

'********************************************************************************************************************************************

Function CollectDonnees(ChemFicTxt As String) As Variant()
'Fonction qui va lister les infos contenues dans le fichier txt
    '- toutes les données des 6 premières colonnes (DonneesGlobales)
        'DonneesGlobales(1, x) = lettre
        'DonneesGlobales(2, x) = N° de compte
        'DonneesGlobales(3, x) = Exercice (Année)
        'DonneesGlobales(4, x) = Mois
        'DonneesGlobales(5, x) = Réf d'UF
        'DonneesGlobales(6, x) = Dépense
    '- les numéros des comptes (DicoCptes)
    '- les références des UF dans le ,fichier txt (DicoUfTxt)
    '- les références des UF "utiles" dans la Feuil1 (DicoUfFeuil)
Dim Ligne As String, TbTemp(), Tb()
Dim num As Long, i As Long, j As Long, Cpt As Integer, DL As Long

    On Error GoTo Fin
    Set DicoCptes = CreateObject("Scripting.Dictionary")
    Set DicoUfTxt = CreateObject("Scripting.Dictionary")
    Set DicoUfFeuil = CreateObject("Scripting.Dictionary")
    DL = Sheets("Feuil1").Range("P" & Rows.Count).End(xlUp).Row
    Tb = Sheets("Feuil1").Range("O2:Q" & DL).Value
    For i = LBound(Tb) To UBound(Tb)
        DicoUfFeuil(CStr(Tb(i, 2))) = Tb(i, 1) & "¤" & Tb(i, 3)
    Next i
    'permet de retrouver le 1er numéro libre de désignation d'un fichier
    num = FreeFile
    'ouvre le fichier en lecture
    Open ChemFicTxt For Input As #num
    'boucle tant que l'on n'a pas atteint la fin du fichier
    While Not EOF(1)
        Line Input #1, Ligne
        If Left(Ligne, 6) <> "Lettre" Then
            Ligne = Replace(Ligne, Chr(160), "")
            j = j + 1
            ReDim Preserve TbTemp(1 To 6, 1 To j)
            For i = 1 To 6
                TbTemp(i, j) = Split(Ligne, Chr(9))(i - 1)
            Next i
            If TbTemp(6, j) = "" Then TbTemp(6, j) = 0
            If Not DicoCptes.exists(CLng(TbTemp(2, j))) Then
                Cpt = Cpt + 1
                DicoCptes(CLng(TbTemp(2, j))) = Cpt
            End If
            If DicoUfFeuil.exists(CStr(TbTemp(5, j))) Then DicoUfTxt(TbTemp(5, j)) = ""
        End If
    Wend
    Close #num
    CollectDonnees = TbTemp: Exit Function
Fin:
    CodeErreur = 3
End Function

'********************************************************************************************************************************************

Function DimSommes(maxi As Long) As Double()
'Dimensionne la variable Sommes()
    'cette variable va permettre de stocker les sommes des dépenses de chaque compte
Dim TbTemp() As Double

    Erase Sommes
    On Error GoTo Fin
    ReDim Preserve TbTemp(1 To maxi, 1 To 12)
    'La variable Sommes va se présenter comme ceci :
        'Sommes(Compteur, Mois) ou compteur = DicoCptes(Numéro_Du_Compte)
    DimSommes = TbTemp
    Exit Function
Fin:
    CodeErreur = 4
End Function

'********************************************************************************************************************************************

Function CalculSommesParComptes(UF As Variant, Mois As Integer, Annee As Integer) As Boolean
'remplit la variable Sommes() en calculant les sommes des dépenses :
    '- jusqu'au mois choisi,
    '- en évitant les années différentes de celle choisie
Dim i As Long

    On Error GoTo Fin
    For i = 1 To UBound(DonneesGlobales, 2)
        'Vérification si l'année (DonneesGlobales(i, 3)) égale à l'année choisie
        If CInt(DonneesGlobales(3, i)) = Annee Then
            'Vérification si mois (DonneesGlobales(i, 4)) inférieur ou égal au mois choisi
            If CInt(DonneesGlobales(4, i)) <= Mois Then
                'Calcul la somme et la stocke dans la variable Sommes()
                    'DonneesGlobales(i, 5) = Numéro d'UF
                    'DonneesGlobales(i, 2) = Numéro de compte
                    'DonneesGlobales(i, 4) = Mois
                    'DonneesGlobales(i, 6) = dépense
                    'Rappel :
                        'La variable Sommes va se présenter comme ceci :
                        'Sommes(Compteur, Mois) ou compteur = DicoCptes(Numéro_Du_Compte)
                'si c'est le bon UF
                If DonneesGlobales(5, i) = UF Then Sommes(DicoCptes(CLng(DonneesGlobales(2, i))), DonneesGlobales(4, i)) = Sommes(DicoCptes(CLng(DonneesGlobales(2, i))), DonneesGlobales(4, i)) + DonneesGlobales(6, i)
            End If
        End If
    Next i
    CalculSommesParComptes = True
    Exit Function
Fin:
    CalculSommesParComptes = False: CodeErreur = 5
End Function

'********************************************************************************************************************************************

Function QuelRange(Wsh As Worksheet) As Range
'Sélection de la plage de cellule, dans la feuille UF, à effacer
'en fonction de la colonne A (si contient n° de compte)
Dim DL As Long, Lig As Long, strRange As String

    On Error GoTo Fin
    With Wsh
        DL = .Range("A" & Rows.Count).End(xlUp).Row
        Set QuelRange = .Range("C8:N8")
        For Lig = 9 To DL
            If .Cells(Lig, 1) <> "" And IsNumeric(.Cells(Lig, 1)) Then Set QuelRange = Union(QuelRange, .Range("C" & Lig & ":N" & Lig))
        Next Lig
    End With
    If QuelRange Is Nothing Then GoTo Fin
    Exit Function
Fin:
    CodeErreur = 6
End Function

'********************************************************************************************************************************************

Function ClearRange(Rng As Range) As Boolean
'Efface la plage de cellules sélectionnée dans la fonction QuelRange

    On Error GoTo Fin
    Rng.ClearContents
    ClearRange = True: Exit Function
Fin:
    ClearRange = False: CodeErreur = 7
End Function

'********************************************************************************************************************************************

Function RempliUF(Sh As Worksheet) As Boolean
'Remplit la feuille UF des données recueillies dans la variables Sommes()
Dim Lig As Long, DLigUF As Long, Col As Integer

    On Error GoTo Fin
    With Sh
        DLigUF = .Range("A" & Rows.Count).End(xlUp).Row
        For Lig = 8 To DLigUF
            If .Cells(Lig, 1) <> "" Then
                For Col = 3 To 14
                    'If Sommes(DicoCptes(.Cells(Lig, 1)), Col - 2) = "" Then Codes(.Cells(Lig, 1), Col - 2) = 0
                    If Not DicoCptes.exists(CLng(.Cells(Lig, 1))) Then
                        Exit For
                    Else
                        .Cells(Lig, Col) = Sommes(DicoCptes(CLng(.Cells(Lig, 1))), Col - 2)
                    End If
                Next Col
            End If
        Next Lig
    End With
    RempliUF = True: Exit Function
Fin:
    RempliUF = False: CodeErreur = 8
End Function

'********************************************************************************************************************************************

Function CreeClasseurs(Sh As Worksheet, Chem As String, Element As Variant, intMois As Integer, intAnnee As Integer, WbkSource As Workbook, NomRecap As String) As Boolean
'Fonction qui va :
    '- Copier la feuille UF dans un nouveau classeur
    '- Renommer cette feuille en : UF xxxx ou xxxx est le numéro d'UF
    '- enregistrer sous ce nouveau classeur (exemple de nom : UF_3211 10_2014.xls)
    '- copier cette feuille dans le classeur "récap" par pole.
        '- si ce classeur récap n'est pas créé alors on le créé
    '- fermer ce classeur
    '- Activer le classeur de la macro pour continuer avec un autre UF
Dim WbkUF As Workbook, WbkRecap As Workbook

    On Error GoTo Fin
    With Sh
        .Copy
    End With
    Set WbkUF = ActiveWorkbook
    With ActiveSheet
        .Name = "UF_" & Element
        WbkUF.SaveAs Chem & "\UF_" & Element & " " & intMois & "_" & intAnnee & ".xls"
        On Error GoTo 0
        On Error GoTo NewClassRecap
        .Copy After:=Workbooks(NomRecap).Sheets(Sheets.Count)
        On Error GoTo 0
        On Error GoTo Fin
        WbkUF.Close
    End With
    WbkSource.Activate
    CreeClasseurs = True: Exit Function
    
NewClassRecap:
    With ActiveSheet
        .Copy
        ActiveWorkbook.SaveAs Chem & "\" & NomRecap & ".xls"
    End With
    WbkUF.Close
    WbkSource.Activate
    CreeClasseurs = True: Exit Function
Fin:
    CreeClasseurs = False: CodeErreur = 9
End Function

'********************************************************************************************************************************************

Function EnvoiMails(NomFic As String, Chem As String, Mois As Integer, Annee As Integer) As Boolean
'Source : http://forum.excel-pratique.com/cours-astuces/excel-outlook-envoi-mail-t29003.html
    Dim ObjOutlook As New Outlook.Application
    Dim oBjMail
    Dim Nom_Fichier As String, Destinataire As String
    Dim Wb As Workbook, Ws As Worksheet

    On Error GoTo Fin
    Set ObjOutlook = New Outlook.Application
    For Each Wb In Application.Workbooks
        If Wb.Name <> NomFic Then
            With Wb
                .Activate
                .Save
            End With
            Set oBjMail = ObjOutlook.CreateItem(olMailItem)
            Nom_Fichier = Chem & "\" & Wb.Name
            Destinataire = Split(DicoUfFeuil(Right(ActiveSheet.Name, 4)), "¤")(1)
            If Nom_Fichier = "" Then EnvoiMails = False: Exit Function
            With oBjMail
                .To = Destinataire
                .Subject = "Fichiers UF, extraction de " & Mois & " " & Annee          ' l'objet du mail
                .Body = "Bonjour," & vbCrLf & vbCrLf & "Veuillez trouver ci-joint les fichiers UF vous concernant." & vbCrLf & vbCrLf & "Cordialement."  'le corps du mail ..son contenu
                .Attachments.Add Nom_Fichier
                For Each Ws In Wb.Worksheets
                    Nom_Fichier = Chem & "\" & Ws.Name & " " & Mois & "_" & Annee & ".xls"
                    .Attachments.Add Nom_Fichier
                Next
                .Send
            End With
            Wb.Close
        End If
    Next
    Set oBjMail = Nothing
    Set ObjOutlook = Nothing
    EnvoiMails = True: Exit Function
Fin:
    Set oBjMail = Nothing
    Set ObjOutlook = Nothing
    EnvoiMails = False: CodeErreur = 10
End Function

'********************************************************************************************************************************************

Function MsgErreur(Optional Msg As String) As String
'Fonction de traitement des différentes erreurs possibles ou imaginaires
    'En cas d'erreur, revenir sur le forum avec le numéro d'erreur ET le message complet

    Application.ScreenUpdating = True
    Select Case CodeErreur
        Case 1: MsgErreur = "Erreur n° 1 : " & vbCrLf & "Fonction InitVariables"
        Case 2: MsgErreur = "Erreur n° 2 : " & vbCrLf & "Fonction CreationRepertoire" & vbCrLf & Msg
        Case 3: MsgErreur = "Erreur n° 3 : " & vbCrLf & "Fonction CollectDonnees"
        Case 4: MsgErreur = "Erreur n° 4 : " & vbCrLf & "Fonction DimSommes, vérifier Mémoire et/ou variable maxi (DicoCptes.Count)"
        Case 5: MsgErreur = "Erreur n° 5 : " & vbCrLf & "Fonction CalculSommesParComptes. Problème dans les données initiales (exemple : montant dépense = """")."
        Case 6: MsgErreur = "Erreur n° 6 : " & vbCrLf & "Fonction QuelRange"
        Case 7: MsgErreur = "Erreur n° 7 : " & vbCrLf & "Fonction ClearRange"
        Case 8: MsgErreur = "Erreur n° 8 : " & vbCrLf & "Fonction RempliUF"
        Case 9: MsgErreur = "Erreur n° 9 : " & vbCrLf & "Fonction CreeClasseurs" & vbCrLf & Msg
        Case 10: MsgErreur = "Erreur n° 10 : " & vbCrLf & "Fonction EnvoiMails"
        Case Else: MsgErreur = "Erreur inconnue." & vbCrLf & "Voir ça avec le forum, ça va pas être simple..."
    End Select
End Function