XL 2019 Ajout d'un bouton DELETE sur mon USF

[Phil Du59]

Bonjour à tous
1°) Sur mon USF je voudrais ajouter un bouton DELETE QSO afin de supprimer moi même la dernière ligne rempli en appuyant sur le bouton si la personne est déjà listé , pour me prévenir j'ai mis une condition en colonne 1 qui me met la case en rouge si déjà enregistré , sur l'image jointe on voit que Paul est listé en 2 et en 5 donc en doublon et en appuyant sur DELETE la dernière ligne soit supprimé . Donc si vous avez le code qui pourrait me faire ça ce serait génial .

2°) Pendant que j'y suis , comment faire pour que mon tableau s'ouvre sur un autre ordi pour que le USF s'adapte à l'écran exemple 15" 17" ou autre
J'attends vos réponses pour déposer mon fichier, Merci pour votre temps , Philippe .

 

[job75]

Bonjour Phil Du59,

Un fichier au lieu d'une image ce serait mieux mais bon, affectez cette macro au bouton :

Sub SupDoublon()
ActiveSheet.ListObjects(1).Range.RemoveDuplicates Columns:=2, Header:=xlYes
End Sub

En supposant qu'il s'agit d'un tableau structuré avec des doublons en 2ème colonne.

A+

 

[Valtrase]

Bonjour à tous,
En plus généraliste, vous avez le choix de supprimer une ligne spécifique.
Dans un module standards coller cette fonction.

Public Function DeleteRow(ByVal table As Excel.ListObject, Optional ByVal indexRow As Long) As Boolean
    Dim result As Boolean
    result = True
    If Not table Is Nothing Then
        With table
            If .ListRows.Count > 0 Then
                If indexRow > 0 Then
                    .ListRows(indexRow).Delete
                Else
                    .ListRows(.ListRows.Count).Delete
                End If
            Else
                result = False
            End If
        End With
    Else
        result = False
    End If
End Function

Sub test102()
    DeleteRow Range(table:="Tableau1").ListObject
End Sub

Et pour l'appel :

Private Sub DeleteQSO_Click()
    If DeleteRow(table:=Range("Tableau1").ListObject, indexRow:=1) Then
        MsgBox "La ligne a été supprimée avec succès !"
    Else
        MsgBox "Une erreur est survenue !" & vbNewLine & _
               "Assurez-vous que le tableau est bien nommé et que l'index de ligne existe !"
    End If
End Sub

 

[Phil Du59]

Oui désolé mais le fichier était trop volumineux donc je vous le mets avec un lien We transfer : https://we.tl/t-sVcTTpeHKI
J'ai quand même testé le VB de Job75 mais j'ai un message d'erreur donc je dois mal m'y prendre (désolé je suis novice en VBA)
Dans un premier temps il faut cliqué sur NEW QSO et c'est là que je remplis la case CALLSIGN qui reste toujours le même nom dans cette colonne et c'est dans la case QRZ que tout se joue , tout les prénoms qui seront dans cette colonne N°3 c'est là que si il y à des doublons (case rouge en colonne 1) je dois pouvoir supprimer la ligne qui correspond de A à K juste en appuyant le bouton DELETE.
Bon j'espère que j'ai été clair dans mes explications et que voyez ce que je voudrais c'est vrai qu'avec l'image que j'ai mis on ne peut pas savoir qu'il faut ouvrir le USF pour mieux voir .
Je suis à votre écoute et encore merci de prendre de votre temps pour mon sujet
Philippe .

 

[job75]

Bonjour Phil Du59, le forum,

Pourquoi utiliser un fichier .xls obsolète depuis Excel 2007 ?

Voyez quand même votre fichier joint et le code de l'UserForm revu et complété :

Private Sub btnAjout_Click() 'Save QSO
Dim lig&
With Sheets("LOG")
    lig = Application.Match("zzz", .[C:C]) + 1
    .Cells(lig, 1).Resize(, 12) = Array(lig - 2, cboActivation, txtQrz, txtRst, Date, Time, cboBand, txtMhz, cboMode, "", "", txtnotes)
End With
txtQrz = ""
txtRst = ""
txtnotes = ""
txtQrz.SetFocus
End Sub

Private Sub CommandButton1_Click() 'DELETE QSO
Dim derlig&
With Sheets("LOG")
    derlig = Application.Match("zzz", .[C:C])
    .Range("A3:M" & derlig).RemoveDuplicates Columns:=3, Header:=xlYes
    .Range("A3:M" & Rows.Count).Interior.Color = vbBlack
End With
End Sub

Mais je ne vois pas où se trouvent les contrôles txtMhz et txtnotes...

A+

 

[job75]

Pour éviter tout problème il vaut mieux reconstruire la MFC, la macro dans ThisWorkbook :

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
With Sheets("LOG")
    With .Range("A3:A" & .Rows.Count)
        .FormatConditions.Delete
        .Cells(1, 12) = "=COUNTIf(C$3:C$" & .Rows.Count & ",C3)>1"
        .FormatConditions.Add xlExpression, Formula1:=.Cells(1, 12).FormulaLocal 'fonctionne dans toutes les langues
        .FormatConditions(1).Interior.Color = vbRed
        .Cells(1, 12) = ""
    End With
End With
End Sub

Elle se déclenche quand on enregistre le fichier.

J'ai enregistré le fichier en .xlsm, c'est mieux.