XL 2021 VBA et UserForm

[Constantin]

Bonjour à tous,
Vous trouverez en PJ un fichier DEMO de ce que j'ai à ce jour réussi à élaborer avec le concours incontournable des XLDNautes qui se reconnaîtront.
Mon fichier comporte deux feuilles:
- Annuaire (=base de données)
- Ma liste, résultant de l'exportation via l'UsfSaisie des données que je souhaite collecter.
Tout cela, grâce aux talents de mes contributeurs (le mot est faible), fonctionne très bien mais je souhaiterai apporter quelques améliorations. Malgré mes efforts et mes recherches, je n'arrive pas à grand chose.
Ce que je voudrais :
- Macro "Alpha": que la sélection se fasse de C2 jusqu'à la première cellule vide, ce qui suppose bien sûr qu'aucun nom ne manque. Pour l'heure j'ai bloqué le tri alphabétique de C2 à C100 ne sachant faire autrement.
- Ma Liste :
* Macro Effacer : même problème qu'avec Alpha...
* Créer une nouvelle macro qui me permettrait d'enregistrer le fichier sous un nouveau nom au format "L3 et "L6.xlsm. Si possible, ajouter des messages box pour informer ou mettre en garde l'utilisateur.
Je demande beaucoup mais malheureusement je n'y arrive pas tout seul.
Bon dimanche à vous tous.
Pierre

 

[vgendron]

Hello

pour ta macro "Alpha" qui permet de trier
pas besoin de chercher la dernière ligne, l'utilisation de table structurée te permet de simplifier le code

Sub Alpha()
    With ActiveWorkbook.Worksheets("Annuaire").ListObjects("TData") 'avec la table "TData"
        .Sort.SortFields.Clear 'on supprime les tris en cours
        .Sort.SortFields.Add2 Key:=.ListColumns("Nom").Range, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal 'on ajoute un tri sur la colonne "Nom"
        With .Sort 'on applique le filtre
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
End Sub

 

[vgendron]

Idem pour "Effacer"

Sub Effacer()
    With Sheets("Ma liste").ListObjects("t_maliste")
        .DataBodyRange.Clear 'on efface le contenu
        .Resize Range("$A$1:$J$2") 'on redimensionne la table avec juste une ligne
    End With
End Sub

 

[fanch55]

Bonjour,
Qu'est censé faire la macro Alpha sur l'annuaire ?
Si c'est ce que je pense , les codes ci-joints devraient suffire :
Edit: Salut @vgendron , je n'ai vu ta réponse qu'en postant la mienne ...

Option Explicit
Sub Alpha()
Dim Cel As Range
    With Worksheets("Annuaire").ListObjects("TData").Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=Range("TData[Nom]"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Set Cel = [Tdata[Nom]].ListObject.Range.Find("", , xlValues, xlWhole)
    If Cel Is Nothing Then
        [Tdata[Nom]].ListObject.ListRows.Add
        Set Cel = [Tdata[Nom]].ListObject.Range.Find("", , xlValues, xlWhole)
    End If
    Cel.Select
End Sub
Sub Effacer_Annuaire()
    If Not [Tdata].ListObject.DataBodyRange Is Nothing _
    Then [Tdata].ListObject.DataBodyRange.Delete
End Sub
Sub Effacer_Liste()
    If Not [T_maliste].ListObject.DataBodyRange Is Nothing _
    Then [T_maliste].ListObject.DataBodyRange.Delete
End Sub

 

[fanch55]

Pour la dernière demande :

Autres - msgbox : mettre en garde du risque de fermer un fichier

Bonjour Sur une application utilisée par des bénévoles pas trop au top en informatique, je voudrais mettre une MsgBox pour les informer de ne pas fermer un fichier qui fonctionne en liaison avec l'application mais après de nombreux essais je ne comprends pas pourquoi ça bloque, qu'elle est...

excel-downloads.com

 

[Constantin]

Idem pour "Effacer"

Sub Effacer()
    With Sheets("Ma liste").ListObjects("t_maliste")
        .DataBodyRange.Clear 'on efface le contenu
        .Resize Range("$A$1:$J$2") 'on redimensionne la table avec juste une ligne
    End With
End Sub

Merci Vgendron,
Toujours fidèle au poste ? Tu ne me croiras sans doute pas, mais j'ai compris ton code et je me rends compte une fois de plus de mon ignorance.
Le temps d'avaler mon dessert avec ma petite famille et je teste. Merci en tous les cas de l'ajout des commentaires qui illustrent le contenu des codes.
Restera ma dernière requête sur la quelle je sèche :
* Créer une nouvelle macro qui me permettrait d'enregistrer le fichier sous un nouveau nom au format "L3 et "L6.xlsm. Si possible, ajouter des messages box pour informer ou mettre en garde l'utilisateur.
Sous entendu, les L3 et L6 sont dans la feuille Ma Liste.
Mille mercis,
Pierre

 

[Constantin]

Bonjour,
Qu'est censé faire la macro Alpha sur l'annuaire ?
Si c'est ce que je pense , les codes ci-joints devraient suffire :
Edit: Salut @vgendron , je n'ai vu ta réponse qu'en postant la mienne ...

Option Explicit
Sub Alpha()
Dim Cel As Range
    With Worksheets("Annuaire").ListObjects("TData").Sort
        .SortFields.Clear
        .SortFields.Add2 Key:=Range("TData[Nom]"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Set Cel = [Tdata[Nom]].ListObject.Range.Find("", , xlValues, xlWhole)
    If Cel Is Nothing Then
        [Tdata[Nom]].ListObject.ListRows.Add
        Set Cel = [Tdata[Nom]].ListObject.Range.Find("", , xlValues, xlWhole)
    End If
    Cel.Select
End Sub
Sub Effacer_Annuaire()
    If Not [Tdata].ListObject.DataBodyRange Is Nothing _
    Then [Tdata].ListObject.DataBodyRange.Delete
End Sub
Sub Effacer_Liste()
    If Not [T_maliste].ListObject.DataBodyRange Is Nothing _
    Then [T_maliste].ListObject.DataBodyRange.Delete
End Sub

Bonjour Fanch55,
Cette macro a pour but de trier les noms en ordre alphabétique pour qu'ils apparaissent dans cet ordre logique dans la saisie des noms dans UsfSaisie.
Je reviens dans deux heures pour tester tous ces codes.
Merci encore !
Pierre

 

[Constantin]

Bonjour à tous,
J'ai testé les deux codes et ça fonctionne à merveille. Je vais essayer d'introduire un MsgBox dans la macro "Effacer" pour alerter l'utilisateur et au besoin le faire renoncer tant qu'il n'a pas fait une sauvegarde explicite.
J'ai honte ! Vgendron m'a pourtant initié à l'utilisation des tables dans une précédente discussion. J'ai peur que l'on ne m'oblige à redoubler ma classe
Pierre
PS : J'ai essayé d'utiliser des suggestions du forum et je butte sur FileFormat qui ne veut pas que je sauvegarde en xlsm. Moi pas comprendre...

 

[fanch55]

Pour la sauvegarde, code adapté :

Private Sub SaveMe()
   
    Select Case MsgBox("Voulez-vous" & vbLf & vbLf & _
        "(oui) sauvegarder ce classeur uniquement" & vbLf & _
        "(non) le sauvegarder également dans L3 et l6" _
        , vbCritical + vbYesNoCancel)
    Case vbYes
        ThisWorkbook.Save
    Case vbNo
        ThisWorkbook.Save
        Application.DisplayAlerts = False ' pour ne pas avoir la demande de remplacement
        ThisWorkbook.SaveAs "C:\sauvegardes-biblio\" & "L3.xlsm" 'Changer le chemin
        ThisWorkbook.SaveAs "F:\Bibliotheque\" & "L6.xlsm" 'Changer le chemin
    End Select
   
End Sub

 

[Constantin]

Bonjour Fanch55,
Merci de ta réponse mais, une fois de plus j'ai du mal exprimer ma demande.
Il ne s'agit pas de sauvegarder le fichier en L3.xslm et ou L6.xslm mais d'intégrer le contenu des valeurs L3 et L6 de la feuille Ma liste pour construire le nom de la sauvegarde. On pourrait obtenir par exemple un nom qui serait "Annuaire_Vacances_26-06-2023.xlsm". Cette archivage, non seulement indiquerait la nature du contenu mais permettrait au besoin de la reprendre pour la modifier au besoin (ajout ou suppression de ligne) manuellement, cela s'entend. D'après ce que j'ai pur voir sur le forum, le code intègre quelque chose comme "Range("L3").value&_&Range("L7").value puis propose un format d'enregistrement qui, malheureusement ne prend pas en compte le format xlsm. Le code proposé est le suivant:
Private Sub filename_cellvalue() que je remplacerai par Sub SaveAs mais je ne sais pas trop comment faire
'Update 20141112 Inutile, j'imagine
Dim Path As String
Dim filename As String
Path = "C:\Users\dt\Desktop\my information\" que je remplacerai par le chemin de mon fichier
filename = Range("A1") que je remplacerai par "Annuaire"&"_"&range("L3")&"_"&range("L7")
ActiveWorkbook.SaveAs filename:=Path & filename & ".xls", FileFormat:=xlNormal
End Sub
Je ne sais pas trop ce qu'est une "Private Sub", préférant une macro définie par Sub
Mais ce qui "merde", c'est le code filename & ".xls", FileFormat:=xlNormal.
J'ai suivi le fil de la discussion et de toute évidence je ne suis pas le seul à avoir constater ce bugue.
Je te joins le lien de cette discussion :

https://fr.extendoffice.com/documents/excel/2266-excel-save-file-as-cell-value.html

Mille mercis de ta patience et bonne journée.
Pierre

 

[Constantin]

Pardon pour les fautes d'orthographe... A mon âge c'est nul !

 

[Dranreb]

Bonjour.
xlNormal ne me semble pas faire partie de l'énumération XlFileFormat.
C'est xlOpenXMLWorkbookMacroEnabled, normalement pour un xlsm

 

[Constantin]

Merci Draneb,
Comment dois-je "syntaxer" cette donnée dans mon code ? Comme çà ?
FileFormat:=xlOpenXMLWorkbookMacroEnabled
Ravi de ton contact,
Bien amicalement,
Nitnatsnoc

 

[Dranreb]

Oui, ben sûr.
Remarque, je pense que si on ne précise pas le paramètre, il reconduit celui du classeur à sauvegarder.

 

[Constantin]

J'essaye !
Merci encore
Pierre