Besoin d'aide en Visual Basic ! Résolu/Fermé

Question

Bonjour,
J'ai besoin pour un projet de développer une macro excel.
Cette macro a pour but, à partir d'un fichier excel existant (résultat d'une requête sql), de séparer les informations qu'il contient, de les mettrent en fome sur une nouvelle feuille et d'enregistrer ces infos dans des fichiers différents au format html.
Tout cela devant bien sur se faire automatiquement !
Le problème est que je suis débutant complet en visual basic...
J'ai fais un algorithme de la macro en c++, j'aurais besoin que quelqu'un me donne une traduction (les grandes lignes..) de cet algo.
Voici l'algo :


string cellule_test = contenu de la cellule L2C1;

while (cellule_test != cellule vide)
{
	string cellule_ref = contenu de la cellule suivante de la colonne C1;
	selection = selectionner la ligne courante;

	string cellule_courante = contenu de la cellule suivante de la colonne C1;

	while (cellule_ref == cellule_courante)
	{
		selection = selection + selectionner la ligne courante;
		cellule_courante = contenu de la cellule suivante de la colonne C1;

	}
	//traitement sur les lignes selectionnées
	cellule_test = contenu de la LxC1
}

J'espère que cet algo est assez clair...

Merci par avance à ceux qui me répondront !
A ++

Utilisateur anonyme · Answer

Bonjour,

Je n'ai pas réellement saisi votre algo !

Mais voici un début de code !


Sub Travaux()

    Dim Limite As Long, Boucle As Long
    Dim Cellule_Test As String
    Dim Cellule_Ref As String
    
    'string cellule_test = contenu de la cellule L2C1;
    Cellule_Test = Range("A2").Value
    Limite = Range("A1:A65535").End(xlDown).Row
    'while (cellule_test != cellule vide)
    For Boucle = 1 To Limite
        'string cellule_ref = contenu de la cellule suivante de la colonne C1;
        Cellule_Ref = Cells(Boucle, 3).Value
        ' Ligne courante
        MsgBox Cells(Boucle, 1).Value
        ' Ligne courante, colonne C
        MsgBox Cells(Boucle, 3).Value
        ' suite du code...
        
    Next Boucle
    
End Sub
'


Lupin

jaacki · Answer

Bonjour Lupin,
merci pour cette réponse très rapide,
j'ai quelques questions :
- cette instruction renvoie le numéro de la ligne qui est vide ??
Range("A1:A65535").End(xlDown).Row

- je souhaites selectionner toutes les lignes tant que le login est identique
voici un morceau de mon tableau excel :

col 1               col 2     col 3          col 4
login               nom        moy       moy2
scl8764a	jaacki	13,690	UE1 : 14,099
scl8764a	jaacki	13,690	UE1 : 14,099
scl8764a	jaacki	13,690	UE1 : 14,099
scl8764a	jaacki	13,690	UE1 : 14,099
scl8764a	jaacki	13,690	UE1 : 14,099
scl8764a	jaacki	13,690	UE1 : 14,099
scl8764a	jaacki	13,690	UE1 : 14,099
scl8764a	jaacki	13,690	UE1 : 14,099
scl8764a	jaacki	13,690	UE1 : 14,099
scl8764a	jaacki	13,690	UE1 : 14,099
tlh9182a	robert	14,002	UE1 : 14,082
tlh9182a	robert	14,002	UE1 : 14,082
tlh9182a	robert	14,002	UE1 : 14,082
tlh9182a	robert	14,002	UE1 : 14,082
tlh9182a	robert	14,002	UE1 : 14,082
tlh9182a	robert	14,002	UE1 : 14,082

En fait, chaque fois que le login change, je veux arreter la selection.

- je ne comprend pas ce que fais cette instruction :
MsgBox Cells(Boucle, 1).Value

Merci !

Utilisateur anonyme · Answer

re :

- cette instruction renvoie le numéro de la ligne qui est vide ?? 
Range("A1:A65535").End(xlDown).Row 

Oui

- je ne comprend pas ce que fais cette instruction : 
MsgBox Cells(Boucle, 1).Value 

Affiche un message avec la valeur de la cellule [ ligne:boucle colonne 1 ] où boucle passe de 1 à limite

***********************************************************

alors je comprends mieux ce que tu veux faire !


Sub Travaux()

    Dim Cellule_Ref As String
    Dim lngDebut As Long, lngFinal As Long
    Dim CibleSelection As String
    
    Cellule_Ref = Range("A2").Value
    Range("A2").Select: lngDebut = 2
    While (ActiveCell.Value = Cellule_Ref)
        ActiveCell.Offset(1, 0).Select
        If (ActiveCell.Value <> Cellule_Ref) Then
            lngFinal = ActiveCell.Row - 1
        End If
    Wend
        
    CibleSelection = lngDebut & ":" & lngFinal
    Rows(CibleSelection).Select

    ' À suivre ...
   
End Sub
'


et après la sélection, que faire ?

Lupin

jaacki · Answer

Merci beaucoup pour ce code !
Cette à l'air de marcher pas mal du tout !
Après la selection, je coupe et colle la selection dans une nouvelle feuille, je met en forme les informations (ce sont des notes) et je dois enregistrer automatiquement cette nouvelle feuille dans un fichier .html avec comme nom "login.html".
par exemple pour mon tableau de tout a l'heure scl8764a.html, tlh9182a.html etc...
Tu vois ce que je veux faire ?
Je suppose qu'il est possible de la faire automatiquement en récupérant le login présent sur le tableau ?

Voici mon code actuel :

Sub mise_en_forme_F1()
'
' mise_en_forme_F1 Macro
'
  Dim Cellule_Ref As String
  Dim lngDebut As Long, lngFinal As Long
  Dim CibleSelection As String
    
  'initialisation de la string de reférence
  Cellule_Ref = Range("A2").Value
  
  'selection de la ligne 2
  Range("A2").Select: lngDebut = 2
  
  'boucle de selection
  While (ActiveCell.Value = Cellule_Ref)
    ActiveCell.Offset(1, 0).Select
    
    'si la valeur de la cellule actuelle est différente de la valeur de référence, on termine la selection
    If (ActiveCell.Value <> Cellule_Ref) Then
      lngFinal = ActiveCell.Row - 1
    End If
  Wend
    
  CibleSelection = lngDebut & ":" & lngFinal
  Rows(CibleSelection).Select
  
  'fin de la selection
  'coupe les infos
    Selection.Cut
    Sheets("Feuil2").Select
    Rows("5:5").Select
    ActiveSheet.Paste
    
'mise en forme des informations sur la page
'la je réalise la macro avec l'enregistrement automatique fournit avec excel...   

'enregistrement dans un fichier .html
End Sub

Ce code fonctionne pour un fichier, je dois le faire autant de fois qu'il y a de logins différents...

Merci.

Jaacki

Utilisateur anonyme · Answer

re :

ben voilà, ça prend forme :-)


Sub Travaux()

    Dim Cellule_Ref As String
    Dim lngDebut As Long, lngFinal As Long
    Dim CibleSelection As String
    Dim Chemin As String
    
    ' Recherche du répertoire cible de sauvegarde
    Chemin = ActiveWorkbook.Path & "\"
    
    ' Boucle pour chaque identifiant
    Do
        Cellule_Ref = Range("A2").Value
        Range("A2").Select: lngDebut = 2
        While (ActiveCell.Value = Cellule_Ref)
            ActiveCell.Offset(1, 0).Select
            If (ActiveCell.Value <> Cellule_Ref) Then
                lngFinal = ActiveCell.Row - 1
            End If
        Wend
            
        CibleSelection = lngDebut & ":" & lngFinal
        Rows(CibleSelection).Select
        
        'fin de la selection coupe les infos
        Selection.Cut
        ' Ajoute nouveau classeur
        Workbooks.Add
        ' Cible de copie  -> on "paste" tjrs ds une cellule
        Range("A5").Select
        ActiveSheet.Paste
        ' Suite de mise en forme
        ' ...

        ' Sauvegarde au format HTML
        ActiveWorkbook.SaveAs Filename:=Chemin & Cellule_Ref & ".html", _
            FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False

        ' Fermeture du nouveau classeur
        ActiveWindow.Close

        ' Destruction de la sélection vidé
        Selection.Delete Shift:=xlUp

        ' Rpositionnement - Instruction facultative
        Range("A2").Select

    Loop Until (ActiveCell.Value = "")
    
End Sub
'

Utilisateur anonyme · Answer

re:

attention à cette ligne :

ActiveWorkbook.SaveAs Filename:=Chemin & Cellule_Ref & ".html", _
            FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False

Lupin

Utilisateur anonyme · Answer

re :

J'ai pris un peu de temps pour musclé l'application et y placé de nouvelles instructions.

Bien entendu, tu prends ce qui te convient !


Option Explicit

Type typPosition
    strClasseur As String
    strFeuille As String
    strAdresse As String
End Type
'

Sub Travaux()

    Dim strCellule_Ref As String
    Dim lngDebut As Long, lngFinal As Long
    Dim CibleSelection As String
    Dim strChemin As String
    Dim objPos As typPosition
    
    ' Contrôle de l'application
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    objPos.strFeuille = ActiveSheet.Name
    objPos.strClasseur = ActiveWorkbook.Name
    objPos.strAdresse = ActiveCell.Address
    
    ' Recherche du répertoire cible de sauvegarde
    strChemin = ActiveWorkbook.Path & "\"
    ' Positionnement dans le classeur
    Sheets("Feuil1").Select
    ' Boucle pour chaque identifiant
    Do
        ' Capture du premier élément (id)
        strCellule_Ref = Range("A2").Value
        ' Positionnement de cellule : affectation de variable
        Range("A2").Select: lngDebut = 2
        ' Boucle TanTQuE ( La cellule active égale l'élément capturer )
        While (ActiveCell.Value = strCellule_Ref)
            ' Incrémentation d'une ligne
            ActiveCell.Offset(1, 0).Select
            ' Si la cellule active est différente de l'élément capturer
            If (ActiveCell.Value <> strCellule_Ref) Then
                ' Position finale de la sélection
                lngFinal = ActiveCell.Row - 1
            End If
        Wend
        ' Création de la plage de ligne à sélectionner
        CibleSelection = lngDebut & ":" & lngFinal
        ' Sélection de la plage
        Rows(CibleSelection).Select
        ' Fin de la selection
        
        ' Coupe les infos
        Selection.Cut
        ' Ajoute nouveau classeur
        Workbooks.Add
        ' Sélectionne cible de copie  -> on "paste" tjrs ds une cellule
        Range("A5").Select
        ' Colle les infos
        ActiveSheet.Paste
        ' Sauvegarde au format HTML
        ActiveWorkbook.SaveAs _
            Filename:=strChemin & strCellule_Ref & ".html", _
            FileFormat:=xlHtml, ReadOnlyRecommended:=False, _
            CreateBackup:=False
        ' Fermeture du nouveau classeur
        ActiveWorkbook.Close
        ' Retour au classeur d'origine
        Workbooks(objPos.strClasseur).Activate
        ' Destruction des lignes de la sélection vidé
        Selection.Delete Shift:=xlUp
        ' Repositionnement de cellule
        Range("A2").Select
    Loop Until (ActiveCell.Value = "")
    
    ' Redoone le contrôle
    Workbooks(objPos.strClasseur).Activate
    Sheets(objPos.strFeuille).Select
    Range(objPos.strAdresse).Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
'

Lupin

jaacki · Answer

Merci beaucoup Lupin pour cet interêt que tu portes à mon projet !
J'ai refais un tour sur le forum ce soir pour voir les réponses mais je regarderais le code plus en détail demain...
Je tiendrais informé de l'évolution !

Merci beaucoup en tout cas.

Jaacki

jaacki · Answer

Je viens de tester ton code à l'instant et j'ai encore quelques questions (c'est fou hein !?)

Tout d'abord :
que fait ce code ?
Option Explicit

Type typPosition
    strClasseur As String
    strFeuille As String
    strAdresse As String
End Type

et celui-ci ?
' Contrôle de l'application
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    objPos.strFeuille = ActiveSheet.Name
    objPos.strClasseur = ActiveWorkbook.Name
    objPos.strAdresse = ActiveCell.Address
' Redoone le contrôle
    Workbooks(objPos.strClasseur).Activate
    Sheets(objPos.strFeuille).Select
    Range(objPos.strAdresse).Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

Ensuite, j'ai tester ton code pour sauvegarder en html, il marche nickel mais je voudrait qu'au lieu de sauver la classeur en entier la macro ne sauve que la feuille en cours tu vois ?
j'ai essayé avec ActiveSheet.SaveAs mais le résultat est le même...

Enfin je voudrais que le chemin du repertoire de sauvegarde des fichiers soit demander a l'utilisateur par une boite de dialogue si c'est possible ?

Merci beaucoup !

Jaacki

Utilisateur anonyme · Answer

rebonjour jaacki, donc je vais tenter de ne pas te perdre dans mon cheminement ! La routine devient dangereusement trop longue et et trop complexe pour une bonne gestion future. Je suggère donc de diviser pour règner, philosophie cartésienne à partir de ceci : Option Explicit ' En C++ -> Déclaration de structures ' En VB -> Déclaration de types personnalisés ' Type typPosition strClasseur As String strFeuille As String strAdresse As String End Type ' Sub ModeleCapture() Dim strCellule_Ref As String Dim lngDebut As Long, lngFinal As Long Dim CibleSelection As String Dim strChemin As String Dim objPos As typPosition ' Désactive les messages d'alerts de Excel ' Exemple : Au moment d'écraser un fichier ' existant Excel popup une validation Application.DisplayAlerts = False ' Pendant l'exécution de la routine ' n'affiche pas les changement à l'écran ' Cette instruction rend la vitesse d'exécution ' beaucoup plus rapide ( 10 fois min ) Application.ScreenUpdating = False ' Sauvegarde la position du classeur actuel ' Sauvagarde le nom de la feuille active objPos.strFeuille = ActiveSheet.Name ' Sauvagarde le nom du classeur actif objPos.strClasseur = ActiveWorkbook.Name ' Sauvagarde le nom de la cellule active objPos.strAdresse = ActiveCell.Address strChemin = ActiveWorkbook.Path & "\" Sheets("Feuil1").Select Do strCellule_Ref = Range("A2").Value '--------------------------------------Section1 Range("A2").Select: lngDebut = 2 While (ActiveCell.Value = strCellule_Ref) ActiveCell.Offset(1, 0).Select If (ActiveCell.Value <> strCellule_Ref) Then lngFinal = ActiveCell.Row - 1 End If Wend CibleSelection = lngDebut & ":" & lngFinal Rows(CibleSelection).Select '------------------------------------FinSection1 '--------------------------------------Section2 Selection.Cut Workbooks.Add Range("A5").Select ActiveSheet.Paste ' Traitement en mise en forme ' ... '------------------------------------FinSection2 '--------------------------------------Section3 ActiveWorkbook.SaveAs _ Filename:=strChemin & strCellule_Ref & ".html", _ FileFormat:=xlHtml, ReadOnlyRecommended:=False, _ CreateBackup:=False ActiveWorkbook.Close '------------------------------------FinSection3 Workbooks(objPos.strClasseur).Activate Selection.Delete Shift:=xlUp Range("A2").Select Loop Until (ActiveCell.Value = "") Workbooks(objPos.strClasseur).Activate Sheets(objPos.strFeuille).Select Range(objPos.strAdresse).Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub ' j'ai converti le tout en ceci : 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 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 = ActiveWorkbook.Path & "\" Sheets("Feuil1").Select Do fctSelection_Plage obSl fctTraitementPlage Selection fctSauvegardePlage strChemin & obSl.strCelluleRef Workbooks(obPos.strClasseur).Activate Selection.Delete Shift:=xlUp Range("A2").Select 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) As Boolean Dim Indice As Long fctTraitementPlage = False rngPlage.Cut Indice = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1 Workbooks.Add Range("A5").Select ActiveSheet.Paste ' Traitement en mise en forme ' ... Application.SheetsInNewWorkbook = Indice fctTraitementPlage = True End Function ' Private Function fctSauvegardePlage(strPath As String) As Boolean ActiveWorkbook.SaveAs _ Filename:=strPath & ".html", _ FileFormat:=xlHtml, ReadOnlyRecommended:=False, _ CreateBackup:=False ActiveWorkbook.Close End Function ' J'ai pu ajouter l'instruction permettant de n'avoir qu'une feuille dans le nouveau classeur créé. Pour la boite de dialogue afin de cibler le répertoire je te reviens, ce sera déjà plus simple à intégré dans la décomposition que j'ai faite. @+ Lupin

jaacki · Answer

re !
Je viens de tester le code et il plante à cet endroit :
ActiveSheet.Paste de la fontion "fctTraitementPlage", il a bien ouvert un nouveau classeur avec une seule feuille mais il ne veut pas coller les cellules coupées dedans.
Il me dit "erreur d'éxécution 1004" ...

C'est bizarre parce que ce code est le même qu'avant...  
le problème doit venir de là :
Indice = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    Workbooks.Add
non ?

Utilisateur anonyme · Answer

re :

effectivement, ça plante aussi chez moi, comme spécifié, j'ai rajouté l'instruction car j'avais au préalable codé avant de voir ton message alors j'ai ajouté cet instruction que je connaissais sans la tester !. Je suis désolé, tu as été plus rapide que moi pour tester !.

ceci dit, le code devient :

Private Function fctTraitementPlage(ByVal rngPlage As Range) As Boolean

    fctTraitementPlage = False
    rngPlage.Cut
    Workbooks.Add
    Range("A5").Select
    ActiveSheet.Paste
    ' Traitement en mise en forme
    ' ...
    fctTraitementPlage = True

End Function
'


il y a une solution, mais ce n'est pas celle-la !

je test la boite de dialogue actuellement !

@+
Lupin

Utilisateur anonyme · Answer

Bonsoir,

alors voilà, j'ai trouvé je crois ! [ xlDialogPublishAsWebPage ]
attention, je suis moins familier avec cette boite de dialogue que je n'ai jamais utilisé !

la fonction de sauvegarde, mais je remets tout le code  :


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 = ActiveWorkbook.Path & "\"
    Sheets("Feuil1").Select
    Do
        fctSelection_Plage obSl
        fctTraitementPlage Selection, obSl
        fctSauvegardePlage obSl, strChemin
        Workbooks(obPos.strClasseur).Activate
        Selection.Delete Shift:=xlUp
        Range("A2").Select
    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

    fctTraitementPlage = False
    rngPlage.Cut
    Workbooks.Add
    objS.strNomNewFile = ActiveWorkbook.Name
    Range("A5").Select
    ActiveSheet.Paste
    ' Traitement en mise en forme
    Range("A1").Select
    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 = "Identifiant " & objSel.strCelluleRef
        .AutoRepublish = True
    End With
    Application.Dialogs(xlDialogPublishAsWebPage).Application.DefaultFilePath = strPath
    Application.Dialogs(xlDialogPublishAsWebPage).Application.DefaultSaveFormat = xlHtml
    Application.Dialogs(xlDialogPublishAsWebPage).Show
    ActiveWorkbook.Close
    fctSauvegardePlage = True
    
End Function
'


Lupin

Utilisateur anonyme · Answer

suite :

ce que je veux te dire depuis le début ...

les noms de variables et d'objet sont choisi de façon à ce que
tu tape les 4 premiers caractère + [Ctrl] & [ Spacebar ]
tu obtients une liste :-)

c'est très efficace et très rapide.

Lupin

jaacki · Answer

Salut Lupin ! J'ai pris le temps ce soir de bien continuer mon code et je l'ai presque achevé ! Voici ce que j'ai : 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: otes\" Sheets("Feuil1").Select Do fctSelection_Plage obSl fctTraitementPlage Selection, obSl fctSauvegardePlage obSl, strChemin Workbooks(obPos.strClasseur).Activate Selection.Delete Shift:=xlUp Range("A2").Select 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 ' Traitement en mise en forme Columns("A:A").ColumnWidth = 22.14 Columns("B:B").ColumnWidth = 33.57 ' Initialisation des cellules statiques Cells(1, 1) = Cells(40, 2).Value Cells(2, 1) = "Moyenne générale : " & Cells(40, 3).Value Cells(4, 1) = Cells(40, 4).Value Cells(5, 1) = "Date" Cells(5, 2) = "Contrôle" Cells(5, 3) = "Coeff" Cells(5, 4) = "Note" ' 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 ' On efface les cellules inutiles Range("A40:H140").Select Selection.Clear 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 ' Je te le met pour que tu vois un peu ce que je voulais faire pour la mise en forme. J'ai un petit dernier problème : Au moment ou j'efface les cellules temporairement utilisées pour coller les infos, il garde quand même en mémoire que j'ai modifié ces cellules et du coup il me les saugardes quand même dans le fichier html, elle sont vides mais elles existent... Il n'existerais pas une fonction du genre "Selection.SetAsDefault" ou un truc dans le genre pour remettre les cellules comme si je ne les avaient pas modifiées? Merci encore pour ton aide, Bonne soirée Jaacki

jaacki · Answer

Ah oui et concernant la boite de dialogue pour le chemin de sauvegarde, je voudrais simplement une petite boite qui demande de choisir le chemin avec un bouton parcourir mais une seule fois pour toute au début du programme. On choisit le dossier au début et tous les fichiers créés seront sauvés dedans !

Et enfin dernière question : Est-il possible de transformer la macro en un exe autonome qui demanderais juste le tableau excel pour fonctionner ?

Merci 
A +

Utilisateur anonyme · Answer

Bonsoir, comme toujours, tu prends ce qui te plait ! ->La boite de dialogue En fait la boite est venu avec le format html choisi ! Je comprends très bien ce que tu cherche et j'ai un module déjà tout codé, mais le fichier html pourrait être différent, je jete un coup d'oeil. ->L'effacement temporaire Je crois qu'il faut tout simplement créer une copie complète et détruire sur la copie et non couper ! -> Transformer en exe Sous VBA, il y a le XLA, on enregistre le classeur monClasseur.xla, on le transporte d'une machine à l'autre en le déposant dans le repertoire office des macros complémentaires, on l'active dans Excel. --- J'ai toujours la manie de modifier le code que je vois, c'est une déformation professionnel :-) alors comme je le pensais la fonction de traitement devient dangeureusement longue, j'ai comme pratique de toujours voir une routine complète dans un écran ! en analysant le code que tu as ajouté, je retrouve un découpage naturel, genre : Sélection ... Traitement .................Selection_Controles_UE1 ..................................Sélection ..................................Initialisation ..................................Copie ..................................Mise En Forme .................Selection_Controles_UE2 ..................................Sélection ..................................Mise En Forme Sauvegarde ........ ... Bien sur l'objectif est de ne pas répéter du code inutilement. La Sélection et la MiseEnForme pourrait être de courte fonction qui recevraient les paramètres en arguments. J'en profite aussi que toutes les fonctions retournent un booléan pour pouvoir effectuer du contrôle, ex : Sub Capture() Dim strChemin As String Dim obPos As typPosition Dim obSl As typSelection Dim Reponse As Boolean Application.DisplayAlerts = False Application.ScreenUpdating = False obPos.strFeuille = ActiveSheet.Name obPos.strClasseur = ActiveWorkbook.Name obPos.strAdresse = ActiveCell.Address strChemin = "G: otes\" Sheets("Feuil1").Select Do Reponse = fctSelection_Plage(obSl) If (Reponse) Then Reponse = fctTraitementPlage(Selection, obSl) If (Reponse) Then Reponse = fctSauvegardePlage(obSl, strChemin) If (Reponse) Then Workbooks(obPos.strClasseur).Activate Selection.Delete Shift:=xlUp Else DoEvents ' Action en cas d'erreur End If Else DoEvents ' Action en cas d'erreur End If Else DoEvents ' Action en cas d'erreur End If Range("A2").Select Loop Until (ActiveCell.Value = "") Workbooks(obPos.strClasseur).Activate Sheets(obPos.strFeuille).Select Range(obPos.strAdresse).Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub ' voici donc la fonction Traitement modifié : Private Function fctTraitementPlage(ByVal rngPlage As Range, _ ByRef objS As typSelection) As Boolean Dim Indice As Long fctTraitementPlage = False rngPlage.Cut Workbooks.Add objS.strNomNewFile = ActiveWorkbook.Name Range("A40").Select ActiveSheet.Paste ' Traitement en mise en forme Columns("A:A").ColumnWidth = 22.14 Columns("B:B").ColumnWidth = 33.57 ' Initialisation des cellules statiques Cells(1, 1) = Cells(40, 2).Value Cells(2, 1) = "Moyenne générale : " & Cells(40, 3).Value Cells(4, 1) = Cells(40, 4).Value Range("A5:D5") = Array("Date", "Contrôle", "Coeff", "Note") 'Cells(5, 1) = "Date": Cells(5, 2) = "Contrôle" 'Cells(5, 3) = "Coeff": Cells(5, 4) = "Note" Selection_Controles_UE1 Selection_Controles_UE2 ' On efface les cellules inutiles Range("A40:H140").Select Selection.Clear Range("A6").Select fctTraitementPlage = True End Function ' Private Function Selection_Controles_UE1() As Boolean Dim obS2 As typSelection Dim debutE2 As String ' 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).Value = 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 End Function ' Private Function Selection_Controles_UE2() As Boolean Dim obS2 As typSelection Dim debutE2 As String obS2.strCelluleRef = ActiveCell.Value ' 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 End Function ' Lupin

Utilisateur anonyme · Answer

re :

Attention, je n'ai pas tester le code sous découpage.

alors je me disais, si l'appli devient trop lourde il y a moyen de faire
plus compact.

Sachant que : { Range("A1") = [A1] } il est aisé de compacter le
code, toutefois cette façon de faire est plus difficile à entretenir.
C'est pourquoi je décompose tout en fonction de façon à former
un albre algorithmique de mon code.

Naviguant sur le forum mcrosoft excel de france, je vois souvent
ce genre de code, c'en est presque un jeu, de trouver le plus
compact :-)

En regardant une pyramide, il nous faut "voir" un lozange avec
la partie invisible dans la terre.

Lupin

Utilisateur anonyme · Answer

re: alors voilà j'ai testé une partie du code, jusqu'a la ligne [ ' Lupin ]. Je comprends mieux le problème de données temporaire ( la plage [A40:Hxx]). 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: otes\" Sheets("Feuil1").Select Do fctSelection_Plage obSl fctTraitementPlage Selection, obSl fctSauvegardePlage obSl, strChemin Workbooks(obPos.strClasseur).Activate Selection.Delete Shift:=xlUp Range("A2").Select 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 Initialise Selection_Controles_UE1 ' Lupin ' 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 ' On efface les cellules inutiles Range("A40:H140").Select Selection.Clear 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 ' Function Initialise() ' Traitement en mise en forme Columns("A:A").ColumnWidth = 22.14 Columns("B:B").ColumnWidth = 33.57 ' Initialisation des cellules statiques Cells(1, 1) = Cells(40, 2).Value Cells(2, 1) = "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") End Function ' Function Selection_Controles_UE1() Dim obS2 As typSelection ' Selection des controles UE1 obS2.strCibleSelection = "E40:H" & (40 + (objS.lngFinal - objS.lngDebut)) obS2.lngFinal = (40 + (objS.lngFinal - objS.lngDebut)) 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 Cells(obS2.lngDebut, 1).Select ActiveSheet.Paste End Function ' Lupin

Utilisateur anonyme · Answer

Bonjour Jaacki,

alors j'ai eu d'autres chats a fouetter et je suis de retour. Je ne réussi pas à faire rouler la macro tel que tu la codé (message 15).
Pour aller de l'avant, j'aurais besoin que tu me produise un exemple type du produit final recherché. Je ne vois pas encore la
mise en forme final...

Lupin

jaacki · Answer

Bonjour Lupin, Désolé du retard de la réponse mais étant étudiant avec pas mal d'autres partiels à préparer, j'ais un peu mis ce projet de côté... Si tu veux je peux t'envoyer le fichier de départ ainsi que le fichier html obtenu à l'arrivée... Donne moi ton adresse e-mail ou messagerie si tu veux ? Voici le code à l'heure actuel : 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: otes\" 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 ' Voilà pour le moment mais je compte bien m'y remettre d'ici peu ! Merci et bonne soirée ! Jaacki

Utilisateur anonyme · Answer

re :

Comme je te disais plus haut, ça plante dans la fonction [ fctTraitementPlage ].
Dans cette partie plus précisément :


    ' 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


La cellule ciblé par cette instruction :

Range("D" & obS2.lngFinal + 1).Select

est vide. Donc au moment de l'affectation :

obS2.strCelluleRef = ActiveCell.Value

La valeur de obS2.strCelluleRef est vide = ""

donc j'en conclu qu'il me manque des données pour la suite !

je suis frileux a fournir une adresse courriel valide.
tout a l'envers pour déjouer les robots !
arobas_yahoo_point_ca est le domanine.
et l'identifiant est mousnynao.

Lupin

jaacki · Answer

Salut Lupin (et les autres lecteurs d'ailleurs) ! J'ai eu une bonne période de partiel ce qui m'a empêché, enfin disons plutôt démotivé..., pour continuer ce projet de macro mais en ce moment j'ai deux semaines entièrement consacrée à ça, donc j'ai bien repris et avancé ! Je pense que la macro est presque terminée, je te donne le code si jamais tu veux y jeter un oeil vu que tu m'a énormément aidé à la réaliser. J'ai modifié pas mal de trucs depuis la dernière version, nottement les noms des variables pour y voir plus clair ! Voilà le code : 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: otes\" 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 Je te remerci beaucoup de ton aide et si tu y trouves des trucs à optimiser fait moi signe ! Jaacki

Utilisateur anonyme · Answer

Bonjour Jaacki,

Voici quelques observations dans la routine principal :


'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:
otes\"
    'strChemin = "G:
otes\"
        
        
    ' On quitte Excel
    ' ActiveWorkbook.Save ' La méthode [.Save ] est ici facultative
    ' Application.Quit



Tel que précisé, je ne puis testé le code n'ayant pas de données.

Lupin

lina · Answer

j'ai besoin d'aide le plus vite possible ;j'ai besoin de savoir comment creer un emacros avec excel pour sauvegarder mes données dans la base qui j'ai crée, merci a tous.

Besoin d'aide en Visual Basic !

25 réponses

Discussions similaires