Besoin d'aide en Visual Basic !
Résolu
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 ++
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 ++
Configuration: Windows XP Firefox 2.0.0.9
25 réponses
Résumé de la discussion
Le fil porte sur la création d'une macro Excel qui, à partir d'un fichier issu d'une requête SQL, sépare les informations, les transpose sur une feuille et les enregistre en HTML automatiquement. L'auteur est débutant en VBA et cherche une traduction des grandes lignes de son algorithme en code Excel, prêt à l'emploi, compréhensible pour une mise en pratique. Les réponses proposent des variantes VBA pour regrouper les lignes identiques, sélectionner et copier les plages, puis sauvegarder chaque résultat sous forme HTML, avec des ajustements sur les chemins et dialogues. Enfin, des propositions évoquent la limitation de l'enregistrement à la feuille active et l'utilisation d'une boîte de dialogue pour sélectionner le chemin, tout en encourageant une organisation modulaire du code.
-
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.
-
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:\notes\" 'strChemin = "G:\notes\" ' 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
-
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:\notes\" obSl.lngDebut = 2 ' Boucle pour chaque élève Do ' Appel des fonctions fctSelection_Plage obSl fctTraitementPlage Selection, obSl fctSauvegardePlage obSl, strChemin ' On incrémente la variable comptant le nombre de relevés créés nbReleves = nbReleves + 1 ' Retour au classeur d'origine Workbooks(infosClasseur1.strClasseur).Activate ' On selectionne la cellule suivante ' MsgBox "ActiveCell.Row : " & ActiveCell.Row & ", Selection.Rows.Count : " & Selection.Rows.Count & ", Ligne suivante : " & ActiveCell.Row + Selection.Rows.Count obSl.lngDebut = ActiveCell.Row + Selection.Rows.Count Range("A" & ActiveCell.Row + Selection.Rows.Count).Select ' La boucle s'achève lorsqu'on rencontre un cellule vide dans la colonne 1 Loop Until (ActiveCell.Value = "") ' Retour au classeur d'origine Workbooks(infosClasseur1.strClasseur).Activate Sheets(infosClasseur1.strFeuille).Select Range(infosClasseur1.strAdresse).Select ' On met à jour le classeur Application.ScreenUpdating = True ' On remet l'affichage des erreurs Application.DisplayAlerts = True ' Calcul du temps d'execution de la macro nbSecondes = Timer - nbSecondes nbMinutes = (nbSecondes Mod 3600) \ 60 nbSecondes = (nbSecondes Mod 3600) Mod 60 MsgBox (nbReleves & " relevés ont été créés. Temps d'exécution : " & nbMinutes & " minute(s) et " & nbSecondes & " seconde(s)") ' On quitte Excel ' Application.Quit End Sub Private Function fctSelection_Plage(ByRef obS As typSelection) As Boolean On Error Resume Next fctSelection_Plage = False ' On selectionne la première ligne du nouvel élève Range("A" & obS.lngDebut).Select ' On initialise le nom du futur fichier obS.login = ActiveCell.Value ' On initialise la cellule de référence pour tester si c'est le même élève obS.strCelluleRef = ActiveCell.Value ' Boucle de selection While (ActiveCell.Value = obS.strCelluleRef) ' On selectionne cette ligne ActiveCell.Offset(1, 0).Select ' Si la cellule active est différente de la cellule de référence, on enlève un à la selection If (ActiveCell.Value <> obS.strCelluleRef) Then obS.lngFinal = ActiveCell.Row - 1 End If Wend ' Initialisation de la zone de selection obS.strCibleSelection = obS.lngDebut & ":" & obS.lngFinal ' Selection Rows(obS.strCibleSelection).Select fctSelection_Plage = True End Function Private Function fctTraitementPlage(ByVal rngPlage As Range, ByRef obS As typSelection) As Boolean Dim Indice As Long Dim debutE2 As String Dim nbLignesUE2 As Integer 'Nombre de lignes contenues dans la selection Dim infosClasseur2 As typPosition 'Infos sur le 2e classeur fctTraitementPlage = False ' On copie la zone sélectionnée rngPlage.Copy ' On créé un nouveau classeur Workbooks.Add infosClasseur2.strClasseur = ActiveWorkbook.Name ' On selectionne la cellule A40 Range("A40").Select ' On colle la selection ActiveSheet.Paste ' Appel de la fonction Initialisation fctInitialisation ' Selection des controles UE1 Range("D40").Select obS.strCelluleRef = ActiveCell.Value While (ActiveCell.Value = obS.strCelluleRef) ActiveCell.Offset(1, 0).Select If (ActiveCell.Value <> obS.strCelluleRef) Then obS.lngFinal = ActiveCell.Row - 1 End If Wend obS.strCibleSelection = "E40:H" & obS.lngFinal Range(obS.strCibleSelection).Select ' Mise en forme des notes UE1 Selection.Copy Range("A6").Select ActiveSheet.Paste ' Appel de la fonction pour trier les controles de l'UE1 fctTrie Selection ' Initialisation de l'indice de ligne qui va recevoir les notes de l'UE2 obS.lngDebut = (obS.lngFinal - 40) + 8 ' Copie de la cellule UE2 Cells(obS.lngDebut, 1) = Cells(obS.lngFinal + 1, 4).Value ' Copie de la ligne "date,note..." Rows("5:5").Select Selection.Copy Rows(obS.lngDebut + 1 & ":" & obS.lngDebut + 1).Select ActiveSheet.Paste ' Selection des controles UE2 debutE2 = "E" & obS.lngFinal + 1 Range("D" & obS.lngFinal + 1).Select obS.strCelluleRef = ActiveCell.Value While (ActiveCell.Value = obS.strCelluleRef) ActiveCell.Offset(1, 0).Select If (ActiveCell.Value <> obS.strCelluleRef) Then obS.lngFinal = ActiveCell.Row - 1 End If Wend ' On créé la zone contenant tous les controles de UE2 pour les couper obS.strCibleSelection = debutE2 & ":H" & obS.lngFinal ' On selectionne cette zone Range(obS.strCibleSelection).Select ' On compte le nombre de lignes que contient cette selection nbLignesUE2 = Selection.Rows.Count ' On copie les notes UE2 Selection.Copy ' On selectionne la cellule Ax suivante à la ligne contenant les intitulés "Date,Contrôle..." Range("A" & obS.lngDebut + 2).Select ' On colle les contrôles à cet endroit ActiveSheet.Paste ' On appelle la fonction pour trier les controles de l'UE2 fctTrie Selection ' On selectionne le relevé terminé Range("A1:D" & obS.lngDebut + 1 + nbLignesUE2).Select fctFinition Selection, obS, infosClasseur2 fctTraitementPlage = True End Function Private Function fctSauvegardePlage(ByRef obS As typSelection, ByVal strChemin As String) As Boolean fctSauvegardePlage = False ChDir strChemin With ActiveWorkbook.PublishObjects.Add(xlSourceSheet, _ strChemin & obS.login & ".html", "Feuil1" _ , "", xlHtmlStatic, obS.login, "") .HtmlType = xlHtmlStatic .Title = "Relevé de notes" .Publish (False) .AutoRepublish = False End With ' On ferme le classeur actif ActiveWorkbook.Close fctSauvegardePlage = True End Function 'Initialisation des cellules statiques Private Function fctInitialisation() As Boolean fctInitialisation = False ' Recopiage du nom de l'élève Cells(1, 2) = Cells(40, 2).Value ' Ecriture de la cellule "Moyenne générale" Cells(2, 2) = "Moyenne générale : " & Cells(40, 3).Value ' Recopiage de la cellule "UE1" Cells(4, 1) = Cells(40, 4).Value ' Ecriture des cellules "Date, Contrôle, Coeff, Note" Range(Cells(5, 1), Cells(5, 4)) = Array("Date", "Contrôle", "Coeff", "Note") ' Mise en couleur bleu et en gras de la ligne "Date, Contrôle..." Rows("5:5").Select With Selection.Font .Color = -3380936 .Bold = True End With fctInitialisation = True End Function Private Function fctFinition(ByVal rngPlage As Range, ByRef obS As typSelection, ByRef infosClass As typPosition) As Boolean fctFinition = False ' On centre le contenu des cellules With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With ' On coupe le relevé Selection.Cut ' On créé un nouveau classeur Workbooks.Add ' On agrandi le contenu de la colonne contenant les intitulés des controles Columns("B:B").ColumnWidth = 40 ' On selectionne la première cellule pour coller Range("A1").Select ' On colle le relevé ActiveSheet.Paste 'On quitte le 2e classeur Workbooks(infosClass.strClasseur).Close fctFinition = True End Function Private Function fctTrie(ByVal rngPlage As Range) As Boolean fctTrie = False ' Déclaration des variables Dim lastRow As Long Dim firstRow As Long Dim firstColumn As String Dim lastColumn1 As Long Dim lastColumn2 As String ' On récupère les coordonnées de la plage firstColumn = Split(ActiveCell.Address, "$")(1) firstRow = rngPlage.Row lastRow = rngPlage.Rows(rngPlage.Rows.Count).Row lastColumn1 = rngPlage.Columns(rngPlage.Columns.Count).Column Cells(lastRow, lastColumn1).Select lastColumn2 = Split(ActiveCell.Address, "$")(1) ' On trie la selection par la date ' MsgBox (firstColumn & firstRow & ":" & lastColumn2 & lastRow) ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A" & firstRow), _ SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Feuil1").Sort .SetRange Range(firstColumn & firstRow & ":" & lastColumn2 & lastRow) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With fctTrie = True End Function ' Private Function fctCompteNbEleves() Dim nbEleves As Long Dim celluleRef As String Range("A2").Select celluleRef = ActiveCell.Value nbEleves = 1 Do Until (celluleRef = "") ' On change de cellule ActiveCell.Offset(rowOffset:=1).Activate If (ActiveCell.Value <> celluleRef And ActiveCell.Value <> "") Then ' On incrémente la variable comptant le nombre de relevés créés nbEleves = nbEleves + 1 End If ' On met à jour la cellule de référence celluleRef = ActiveCell.Value Loop fctCompteNbEleves = nbEleves End Function
Je te remerci beaucoup de ton aide et si tu y trouves des trucs à optimiser fait moi signe !
Jaacki -
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
-
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:\notes\" Sheets("Feuil1").Select Do fctSelection_Plage obSl fctTraitementPlage Selection, obSl fctSauvegardePlage obSl, strChemin Workbooks(obPos.strClasseur).Activate Selection.Delete Shift:=xlUp Range("A2").Select 'fctFinition Loop Until (ActiveCell.Value = "") Workbooks(obPos.strClasseur).Activate Sheets(obPos.strFeuille).Select Range(obPos.strAdresse).Select Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub ' Private Function fctSelection_Plage(ByRef obS As typSelection) As Boolean On Error Resume Next fctSelection_Plage = False Range("A2").Select: obS.lngDebut = 2 obS.strCelluleRef = ActiveCell.Value While (ActiveCell.Value = obS.strCelluleRef) ActiveCell.Offset(1, 0).Select If (ActiveCell.Value <> obS.strCelluleRef) Then obS.lngFinal = ActiveCell.Row - 1 End If Wend obS.strCibleSelection = obS.lngDebut & ":" & obS.lngFinal Rows(obS.strCibleSelection).Select fctSelection_Plage = True End Function ' Private Function fctTraitementPlage(ByVal rngPlage As Range, ByRef objS As typSelection) As Boolean Dim Indice As Long Dim obS2 As typSelection Dim debutE2 As String fctTraitementPlage = False rngPlage.Cut Workbooks.Add objS.strNomNewFile = ActiveWorkbook.Name Range("A40").Select ActiveSheet.Paste fctInitialisation ' Selection des controles UE1 Range("D40").Select obS2.strCelluleRef = ActiveCell.Value While (ActiveCell.Value = obS2.strCelluleRef) ActiveCell.Offset(1, 0).Select If (ActiveCell.Value <> obS2.strCelluleRef) Then obS2.lngFinal = ActiveCell.Row - 1 End If Wend obS2.strCibleSelection = "E40:H" & obS2.lngFinal Range(obS2.strCibleSelection).Select ' Mise en forme des notes UE1 Selection.Copy Range("A6").Select ActiveSheet.Paste ' Initialisation de l'indice de ligne qui va ' recevoir les notes de l'UE2 obS2.lngDebut = (obS2.lngFinal - 40) + 8 ' Copie de la cellule UE2 Cells(obS2.lngDebut, 1) = Cells(obS2.lngFinal + 1, 4).Value ' Copie de la ligne "date,note..." Rows("5:5").Select Selection.Copy Rows(obS2.lngDebut + 1 & ":" & obS2.lngDebut + 1).Select ActiveSheet.Paste ' Selection des controles UE2 debutE2 = "E" & obS2.lngFinal + 1 Range("D" & obS2.lngFinal + 1).Select obS2.strCelluleRef = ActiveCell.Value While (ActiveCell.Value = obS2.strCelluleRef) ActiveCell.Offset(1, 0).Select If (ActiveCell.Value <> obS2.strCelluleRef) Then obS2.lngFinal = ActiveCell.Row - 1 End If Wend obS2.strCibleSelection = debutE2 & ":H" & obS2.lngFinal Range(obS2.strCibleSelection).Select ' Mise en forme des notes UE2 Selection.Copy Range("A" & obS2.lngDebut + 2).Select ActiveSheet.Paste Range("A1:D" & obS2.lngFinal).Select fctFinition Selection fctTraitementPlage = True End Function ' Private Function fctSauvegardePlage(objSel As typSelection, strPath As String) As Boolean Dim Boucle As Long, strPropriete As String fctSauvegardePlage = False ChDir strPath With ActiveWorkbook.PublishObjects.Add(xlSourceSheet, _ strPath & objSel.strCelluleRef & ".html", "Feuil1" _ , "", xlHtmlStatic, objSel.strNomNewFile, "") .HtmlType = xlHtmlStatic .Title = "Relevé de notes" .Publish (False) .AutoRepublish = False End With ActiveWorkbook.Close fctSauvegardePlage = True End Function ' 'Initialisation des cellules statiques Private Function fctInitialisation() Columns("B:B").ColumnWidth = 35 Cells(1, 2) = Cells(40, 2).Value Cells(2, 2) = "Moyenne générale : " & Cells(40, 3).Value Cells(4, 1) = Cells(40, 4).Value Range(Cells(5, 1), Cells(5, 4)) = Array("Date", "Contrôle", "Coeff", "Note") Rows("5:5").Select With Selection.Font .Color = -3380936 .Bold = True End With End Function ' Le but de cette fonction est de copier les cellules mises en forme ' dans une nouvelle feuille afin que la sauvegarde ne prenne pas les ' cellules vides ayant été modifiées... Private Function fctFinition(ByVal rngPlage As Range) As Boolean fctFinition = False With rngPlage .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With rngPlag.Cut 'fonction inachevée... fctFinition = True End Function '
Voilà pour le moment mais je compte bien m'y remettre d'ici peu !
Merci et bonne soirée !
Jaacki -
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 -
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 -
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 -
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 -
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 + -
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 -
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 -
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 -
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 -
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 ? -
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 -
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é avecActiveSheet.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 -
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 -
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 -
re:
attention à cette ligne :
ActiveWorkbook.SaveAs Filename:=Chemin & Cellule_Ref & ".html", _
FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False
Lupin
- 1
- 2
Suivant
