Besoin d'aide en Visual Basic !

Option Explicit

Type typPosition
    strClasseur As String
    strFeuille As String
    strAdresse As String
End Type
'

Type typSelection
    lngDebut As Long
    lngFinal As Long
    strCibleSelection As String
    strCelluleRef As String
    strNomNewFile As String
End Type
'

Sub Capture()

    Dim strChemin As String
    Dim obPos As typPosition
    Dim obSl As typSelection
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    obPos.strFeuille = ActiveSheet.Name
    obPos.strClasseur = ActiveWorkbook.Name
    obPos.strAdresse = ActiveCell.Address
    
    strChemin = "G:\notes\"
    Sheets("Feuil1").Select
    Do
        fctSelection_Plage obSl
        fctTraitementPlage Selection, obSl
        fctSauvegardePlage obSl, strChemin
        Workbooks(obPos.strClasseur).Activate
        Selection.Delete Shift:=xlUp
        Range("A2").Select
        'fctFinition
    Loop Until (ActiveCell.Value = "")
    
    Workbooks(obPos.strClasseur).Activate
    Sheets(obPos.strFeuille).Select
    Range(obPos.strAdresse).Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
'

Private Function fctSelection_Plage(ByRef obS As typSelection) As Boolean
        
    On Error Resume Next
    fctSelection_Plage = False
    Range("A2").Select: obS.lngDebut = 2
    obS.strCelluleRef = ActiveCell.Value
    While (ActiveCell.Value = obS.strCelluleRef)
        ActiveCell.Offset(1, 0).Select
        If (ActiveCell.Value <> obS.strCelluleRef) Then
            obS.lngFinal = ActiveCell.Row - 1
        End If
    Wend
    obS.strCibleSelection = obS.lngDebut & ":" & obS.lngFinal
    Rows(obS.strCibleSelection).Select
    fctSelection_Plage = True

End Function
'

Private Function fctTraitementPlage(ByVal rngPlage As Range, ByRef objS As typSelection) As Boolean

    Dim Indice As Long
    Dim obS2 As typSelection
    Dim debutE2 As String

    fctTraitementPlage = False
    rngPlage.Cut
    Workbooks.Add
    objS.strNomNewFile = ActiveWorkbook.Name
    Range("A40").Select
    ActiveSheet.Paste
    
    fctInitialisation
    
    ' Selection des controles UE1
    Range("D40").Select
    obS2.strCelluleRef = ActiveCell.Value
    While (ActiveCell.Value = obS2.strCelluleRef)
        ActiveCell.Offset(1, 0).Select
        If (ActiveCell.Value <> obS2.strCelluleRef) Then
            obS2.lngFinal = ActiveCell.Row - 1
        End If
    Wend
    obS2.strCibleSelection = "E40:H" & obS2.lngFinal
    Range(obS2.strCibleSelection).Select
    
    ' Mise en forme des notes UE1
    Selection.Copy
    Range("A6").Select
    ActiveSheet.Paste
    
    ' Initialisation de l'indice de ligne qui va
    ' recevoir les notes de l'UE2
    obS2.lngDebut = (obS2.lngFinal - 40) + 8
    
    ' Copie de la cellule UE2
    Cells(obS2.lngDebut, 1) = Cells(obS2.lngFinal + 1, 4).Value
    
    ' Copie de la ligne "date,note..."
    Rows("5:5").Select
    Selection.Copy
    Rows(obS2.lngDebut + 1 & ":" & obS2.lngDebut + 1).Select
    ActiveSheet.Paste
     
    ' Selection des controles UE2
    debutE2 = "E" & obS2.lngFinal + 1
    Range("D" & obS2.lngFinal + 1).Select
    obS2.strCelluleRef = ActiveCell.Value
    While (ActiveCell.Value = obS2.strCelluleRef)
        ActiveCell.Offset(1, 0).Select
        If (ActiveCell.Value <> obS2.strCelluleRef) Then
            obS2.lngFinal = ActiveCell.Row - 1
        End If
    Wend
    obS2.strCibleSelection = debutE2 & ":H" & obS2.lngFinal
    Range(obS2.strCibleSelection).Select
            
    ' Mise en forme des notes UE2
    Selection.Copy
    Range("A" & obS2.lngDebut + 2).Select
    ActiveSheet.Paste
    
    Range("A1:D" & obS2.lngFinal).Select
    fctFinition Selection
    
    fctTraitementPlage = True

End Function
'

Private Function fctSauvegardePlage(objSel As typSelection, strPath As String) As Boolean
    
    Dim Boucle As Long, strPropriete As String
    
    fctSauvegardePlage = False
    ChDir strPath
    With ActiveWorkbook.PublishObjects.Add(xlSourceSheet, _
        strPath & objSel.strCelluleRef & ".html", "Feuil1" _
        , "", xlHtmlStatic, objSel.strNomNewFile, "")
        .HtmlType = xlHtmlStatic
        .Title = "Relevé de notes"
        .Publish (False)
        .AutoRepublish = False
    End With
    ActiveWorkbook.Close
    fctSauvegardePlage = True
    
End Function
'

'Initialisation des cellules statiques
Private Function fctInitialisation()

    Columns("B:B").ColumnWidth = 35
    
    Cells(1, 2) = Cells(40, 2).Value
    Cells(2, 2) = "Moyenne générale : " & Cells(40, 3).Value
    Cells(4, 1) = Cells(40, 4).Value
    Range(Cells(5, 1), Cells(5, 4)) = Array("Date", "Contrôle", "Coeff", "Note")
    
    Rows("5:5").Select
    With Selection.Font
        .Color = -3380936
        .Bold = True
    End With

End Function

' Le but de cette fonction est de copier les cellules mises en forme
' dans une nouvelle feuille afin que la sauvegarde ne prenne pas les
' cellules vides ayant été modifiées...
Private Function fctFinition(ByVal rngPlage As Range) As Boolean
        
    fctFinition = False
    
    With rngPlage
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    
    rngPlag.Cut
    
    'fonction inachevée...
    
    fctFinition = True

End Function
'

    ' Selection des controles UE2
    DebutE2 = "E" & obS2.lngFinal + 1
    Range("D" & obS2.lngFinal + 1).Select
    obS2.strCelluleRef = ActiveCell.Value
    While (ActiveCell.Value = obS2.strCelluleRef)
        ActiveCell.Offset(1, 0).Select
        If (ActiveCell.Value <> obS2.strCelluleRef) Then
            obS2.lngFinal = ActiveCell.Row - 1
        End If
    Wend

Option Explicit

Type typPosition
    strClasseur As String
    strFeuille As String
    strAdresse As String
End Type

Type typSelection
    lngDebut As Long
    lngFinal As Long
    strCibleSelection As String
    strCelluleRef As String
    login As String
End Type
'

Sub Capture2()
    ' On enlève l'affichage des erreurs
    Application.DisplayAlerts = False
    
    ' On enlève l'affichage de la macro en temps réel
    Application.ScreenUpdating = False
    
    ' Déclaration des variables
    Dim strChemin As String 'Chemin de sauvegarde des relevés
    Dim infosClasseur1 As typPosition 'Informations sur le classeur initial
    Dim obSl As typSelection 'Enregistrement servant à la séparation des notes
    Dim nbEleves As Long 'Nombre d'élèves dans le fichier (calculé avant la création des fichiers)
    Dim nbReleves As Long 'Nombre de relevés créés
    Dim nbSecondes, nbMinutes As Long 'Nombres de secondes et de minutes necessaires pour executer la macro
    
    ' Selection de la feuille Feuill1
    Sheets("Feuil1").Select
    
    ' Initialisation des variables
    nbReleves = 0
    nbEleves = fctCompteNbEleves
    MsgBox "Nombre de fichiers à créer : " & nbEleves & ". Temps estimé : " & (Round(nbEleves * 0.5, 0) Mod 3600) \ 60 & " minute(s) et " & (Round(nbEleves * 0.5, 0) Mod 3600) Mod 60 & " seconde(s)"
    nbSecondes = Timer
    infosClasseur1.strFeuille = ActiveSheet.Name
    infosClasseur1.strClasseur = ActiveWorkbook.Name
    infosClasseur1.strAdresse = ActiveCell.Address
    strChemin = "G:\notes\"
        
    obSl.lngDebut = 2
    ' Boucle pour chaque élève
    Do
        ' Appel des fonctions
        fctSelection_Plage obSl
        fctTraitementPlage Selection, obSl
        fctSauvegardePlage obSl, strChemin
        
        ' On incrémente la variable comptant le nombre de relevés créés
        nbReleves = nbReleves + 1
        
        ' Retour au classeur d'origine
        Workbooks(infosClasseur1.strClasseur).Activate
        
        ' On selectionne la cellule suivante
        ' MsgBox "ActiveCell.Row : " & ActiveCell.Row & ", Selection.Rows.Count : " & Selection.Rows.Count & ", Ligne suivante : " & ActiveCell.Row + Selection.Rows.Count
        obSl.lngDebut = ActiveCell.Row + Selection.Rows.Count
        Range("A" & ActiveCell.Row + Selection.Rows.Count).Select
        
    ' La boucle s'achève lorsqu'on rencontre un cellule vide dans la colonne 1
    Loop Until (ActiveCell.Value = "")
    
    ' Retour au classeur d'origine
    Workbooks(infosClasseur1.strClasseur).Activate
    Sheets(infosClasseur1.strFeuille).Select
    Range(infosClasseur1.strAdresse).Select
    
    ' On met à jour le classeur
    Application.ScreenUpdating = True
    
    ' On remet l'affichage des erreurs
    Application.DisplayAlerts = True
    
    ' Calcul du temps d'execution de la macro
    nbSecondes = Timer - nbSecondes
    nbMinutes = (nbSecondes Mod 3600) \ 60
    nbSecondes = (nbSecondes Mod 3600) Mod 60
    
    MsgBox (nbReleves & " relevés ont été créés. Temps d'exécution : " & nbMinutes & " minute(s) et " & nbSecondes & " seconde(s)")
    ' On quitte Excel
    ' Application.Quit
    
End Sub

Private Function fctSelection_Plage(ByRef obS As typSelection) As Boolean
        
    On Error Resume Next
    fctSelection_Plage = False
    
    ' On selectionne la première ligne du nouvel élève
    Range("A" & obS.lngDebut).Select
    
    ' On initialise le nom du futur fichier
    obS.login = ActiveCell.Value
    
    ' On initialise la cellule de référence pour tester si c'est le même élève
    obS.strCelluleRef = ActiveCell.Value
    
    ' Boucle de selection
    While (ActiveCell.Value = obS.strCelluleRef)
    
        ' On selectionne cette ligne
        ActiveCell.Offset(1, 0).Select
        
        ' Si la cellule active est différente de la cellule de référence, on enlève un à la selection
        If (ActiveCell.Value <> obS.strCelluleRef) Then
            obS.lngFinal = ActiveCell.Row - 1
        End If
    Wend
    
    ' Initialisation de la zone de selection
    obS.strCibleSelection = obS.lngDebut & ":" & obS.lngFinal
    
    ' Selection
    Rows(obS.strCibleSelection).Select
    
    fctSelection_Plage = True

End Function

Private Function fctTraitementPlage(ByVal rngPlage As Range, ByRef obS As typSelection) As Boolean

    Dim Indice As Long
    Dim debutE2 As String
    Dim nbLignesUE2 As Integer 'Nombre de lignes contenues dans la selection
    Dim infosClasseur2 As typPosition 'Infos sur le 2e classeur

    fctTraitementPlage = False
    
    ' On copie la zone sélectionnée
    rngPlage.Copy
    
    ' On créé un nouveau classeur
    Workbooks.Add
    infosClasseur2.strClasseur = ActiveWorkbook.Name
    
    ' On selectionne la cellule A40
    Range("A40").Select
    
    ' On colle la selection
    ActiveSheet.Paste
    
    ' Appel de la fonction Initialisation
    fctInitialisation
    
    ' Selection des controles UE1
    Range("D40").Select
    obS.strCelluleRef = ActiveCell.Value
    While (ActiveCell.Value = obS.strCelluleRef)
        ActiveCell.Offset(1, 0).Select
        If (ActiveCell.Value <> obS.strCelluleRef) Then
            obS.lngFinal = ActiveCell.Row - 1
        End If
    Wend
    obS.strCibleSelection = "E40:H" & obS.lngFinal
    Range(obS.strCibleSelection).Select
    
    ' Mise en forme des notes UE1
    Selection.Copy
    Range("A6").Select
    ActiveSheet.Paste
    
    ' Appel de la fonction pour trier les controles de l'UE1
    fctTrie Selection
    
    ' Initialisation de l'indice de ligne qui va recevoir les notes de l'UE2
    obS.lngDebut = (obS.lngFinal - 40) + 8
    
    ' Copie de la cellule UE2
    Cells(obS.lngDebut, 1) = Cells(obS.lngFinal + 1, 4).Value
    
    ' Copie de la ligne "date,note..."
    Rows("5:5").Select
    Selection.Copy
    Rows(obS.lngDebut + 1 & ":" & obS.lngDebut + 1).Select
    ActiveSheet.Paste
     
    ' Selection des controles UE2
    debutE2 = "E" & obS.lngFinal + 1
    Range("D" & obS.lngFinal + 1).Select
    obS.strCelluleRef = ActiveCell.Value
    While (ActiveCell.Value = obS.strCelluleRef)
        ActiveCell.Offset(1, 0).Select
        If (ActiveCell.Value <> obS.strCelluleRef) Then
            obS.lngFinal = ActiveCell.Row - 1
        End If
    Wend
    
    ' On créé la zone contenant tous les controles de UE2 pour les couper
    obS.strCibleSelection = debutE2 & ":H" & obS.lngFinal
    
    ' On selectionne cette zone
    Range(obS.strCibleSelection).Select
    
    ' On compte le nombre de lignes que contient cette selection
    nbLignesUE2 = Selection.Rows.Count

    ' On copie les notes UE2
    Selection.Copy
    
    ' On selectionne la cellule Ax suivante à la ligne contenant les intitulés "Date,Contrôle..."
    Range("A" & obS.lngDebut + 2).Select
    
    ' On colle les contrôles à cet endroit
    ActiveSheet.Paste
    
    ' On appelle la fonction pour trier les controles de l'UE2
    fctTrie Selection
    
    ' On selectionne le relevé terminé
    Range("A1:D" & obS.lngDebut + 1 + nbLignesUE2).Select
    
    fctFinition Selection, obS, infosClasseur2
    
    fctTraitementPlage = True

End Function

Private Function fctSauvegardePlage(ByRef obS As typSelection, ByVal strChemin As String) As Boolean
    
    fctSauvegardePlage = False
    
    ChDir strChemin
    With ActiveWorkbook.PublishObjects.Add(xlSourceSheet, _
        strChemin & obS.login & ".html", "Feuil1" _
        , "", xlHtmlStatic, obS.login, "")
        .HtmlType = xlHtmlStatic
        .Title = "Relevé de notes"
        .Publish (False)
        .AutoRepublish = False
    End With
    
    ' On ferme le classeur actif
    ActiveWorkbook.Close
    
    fctSauvegardePlage = True
    
End Function

'Initialisation des cellules statiques
Private Function fctInitialisation() As Boolean
    
    fctInitialisation = False
    
    ' Recopiage du nom de l'élève
    Cells(1, 2) = Cells(40, 2).Value
    
    ' Ecriture de la cellule "Moyenne générale"
    Cells(2, 2) = "Moyenne générale : " & Cells(40, 3).Value
    
    ' Recopiage de la cellule "UE1"
    Cells(4, 1) = Cells(40, 4).Value
    
    ' Ecriture des cellules "Date, Contrôle, Coeff, Note"
    Range(Cells(5, 1), Cells(5, 4)) = Array("Date", "Contrôle", "Coeff", "Note")
    
    ' Mise en couleur bleu et en gras de la ligne "Date, Contrôle..."
    Rows("5:5").Select
    With Selection.Font
        .Color = -3380936
        .Bold = True
    End With
    
    fctInitialisation = True

End Function

Private Function fctFinition(ByVal rngPlage As Range, ByRef obS As typSelection, ByRef infosClass As typPosition) As Boolean
         
    fctFinition = False
    
    ' On centre le contenu des cellules
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    
    ' On coupe le relevé
    Selection.Cut
    
    ' On créé un nouveau classeur
    Workbooks.Add
    
    ' On agrandi le contenu de la colonne contenant les intitulés des controles
    Columns("B:B").ColumnWidth = 40
    
    ' On selectionne la première cellule pour coller
    Range("A1").Select
    
    ' On colle le relevé
    ActiveSheet.Paste
    
    'On quitte le 2e classeur
    Workbooks(infosClass.strClasseur).Close
    
    fctFinition = True

End Function

Private Function fctTrie(ByVal rngPlage As Range) As Boolean
        
    fctTrie = False
    
    ' Déclaration des variables
    Dim lastRow As Long
    Dim firstRow As Long
    Dim firstColumn As String
    Dim lastColumn1 As Long
    Dim lastColumn2 As String
    
    ' On récupère les coordonnées de la plage
    firstColumn = Split(ActiveCell.Address, "$")(1)
    firstRow = rngPlage.Row
    lastRow = rngPlage.Rows(rngPlage.Rows.Count).Row
    lastColumn1 = rngPlage.Columns(rngPlage.Columns.Count).Column
    Cells(lastRow, lastColumn1).Select
    lastColumn2 = Split(ActiveCell.Address, "$")(1)
    
    ' On trie la selection par la date
    ' MsgBox (firstColumn & firstRow & ":" & lastColumn2 & lastRow)
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A" & firstRow), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range(firstColumn & firstRow & ":" & lastColumn2 & lastRow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    fctTrie = True

End Function

'
Private Function fctCompteNbEleves()

    Dim nbEleves As Long
    Dim celluleRef As String
    
    Range("A2").Select
    celluleRef = ActiveCell.Value
    nbEleves = 1
    Do Until (celluleRef = "")
    
        ' On change de cellule
        ActiveCell.Offset(rowOffset:=1).Activate
        
        If (ActiveCell.Value <> celluleRef And ActiveCell.Value <> "") Then
            ' On incrémente la variable comptant le nombre de relevés créés
            nbEleves = nbEleves + 1
        End If
        
        ' On met à jour la cellule de référence
        celluleRef = ActiveCell.Value
    Loop

    fctCompteNbEleves = nbEleves
End Function

'Ajout d'un élément
Type typPosition
    strClasseur As String
    strFeuille As String
    strAdresse As String
    strChemin As String
End Type

' Retrait d'un élément
    'Dim strChemin As String 'Chemin de sauvegarde des relevés


'La déclaration de nbSecondes est  [As Variant] et nbMinutes [ As Long ].
' Sous VB - VBA - VBS, les déclarations se font de façon différentes
' Sous VBS
' Dim a,b,c 
' ..Aucun type n'est déclarés et toute variable déclarée est de type Variant de façon native
' Sous VBA et VB6
' La déclaration d'une variable de façon non explicite sera considéré comme de type Variant.
' Dim a , b As Long, c
'..Seul la variable b est de type Long, a et c sont de type Variant
    Dim nbSecondes As Long, nbMinutes As Long 'Nombres de secondes et de minutes necessaires pour executer la macro

' Économie d'espaces sur instructions non complexe    
    ' Initialisation des variables
    nbReleves = 0 : nbEleves = fctCompteNbEleves

' Information appartenant aux mêmes "propriétés" de l'objet typPosition
    infosClasseur1.strChemin = "G:\notes\"
    'strChemin = "G:\notes\"
        
        
    ' On quitte Excel
    ' ActiveWorkbook.Save ' La méthode [.Save ] est ici facultative
    ' Application.Quit