Besoin d'aide en Visual Basic ! Résolu

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:\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
    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:\notes\"
    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:\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
    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

Besoin d'aide en Visual Basic !

25 réponses

Discussions similaires

Newsletters