2 Macro : 1 Suppr. ligne et 1 Suppr. heure

Yann2702

XLDnaute Nouveau
Bonjour à tous,

Je me permets de venir vous solliciter car j'aimerais savoir simplifier des tâches quotidiennes rébarbatives.

1- Dans mon tableau j'ai des bus modifier et j'aimerais en cliquant sur un bouton supprimer tous les bus d'un même type de modification. Ex: Modification Horaire supprimer toutes les lignes (bus) ayant ce type de modification. Et pareil pour tous les types de modifications (Convoi, Horaire, Roulement, Parcours) en ayant un bouton par type de modification.

2- Beaucoup plus complexe et je ne suis pas sur que ce soit réalisable. Je dispose dans mon tableau de deux colonnes heure de départ (HD1 et HD2), j'aimerais pour chacune d'entre elle pouvoir supprimer les bus circulant s avant ou après une certaine heure que j'indiquerai avant d'appuyer sur le bouton. Ex: Supprimer l'ensemble des bus circulants HD1 avant midi.

Je tiens à préciser que ce tableau est un exemple. Mais il peut être beaucoup plus grand. A l'heure actuel je le fais avec des filtres mais devant le faire plusieurs fois par jours j'aimerais m'économiser ces cliques ennuyeux.

En vous remerciant par avance de votre aide.
 

Pièces jointes

  • Cmd_bus.xlsx
    17.2 KB · Affichages: 28

thebenoit59

XLDnaute Accro
Bonjour Yann.
Bonjour vgendron.

Voici le code adapté :
VB:
Option Explicit

Private Sub cmdHeures_Click()
Dim heure As Date
Dim col As Byte
Dim comp$
Dim i&

With Me
    If Not IsDate(.tbHeure.Value) Then MsgBox "Inscrire l'horaire selon le format: hh:mm:ss": Exit Sub
    heure = .tbHeure.Value
    If .obHD1.Value Then
        col = 7
        Else
        col = 14
    End If
End With

With Sheets(3)
    For i = .Cells.Find("*", , , , xlByRows, xlPrevious).Row To 1 Step -1
        Select Case Me.cbPre.Value
            Case True
                If .Cells(i, col).Value < heure Then Rows(i).Delete
            Case False
                If .Cells(i, col).Value < heure Then Rows(i).Delete
        End Select
    Next i
End With

End Sub

Private Sub cmdMod_Click()
Dim i&, tModif$

With Me
    If .cbMod.Value = "" Then Exit Sub
    tModif = .cbMod.Value
End With

With Sheets(3)
    For i = .Cells.Find("*", , , , xlByRows, xlPrevious).Row To 1 Step -1
        If .Cells(i, 18).Value = tModif Then Rows(i).Delete
    Next i
End With

End Sub

Private Sub UserForm_Initialize()
With Me
    .cbMod.List = Array("Modification Convoi", "Modification Horaire", "Modification Roulement", "Modification Parcours")
    .obHD1.Value = True
End With
End Sub

Comme pensé, tu n'as pas de tableaux objets dans ta feuille donc la méthodologie ne fonctionne pas.
Nous partons sur une bête boucle, les changements ne sont pas énormes.

Essaye, quand tu postes une demande, d'avoir un fichier exemple qui ressemble au plus proche du fichier de travail. Ca ne paraît pas être une grande différence, mais les méthodes de travail peuvent ne pas être les mêmes.

Dans l'attente de ton retour.
 

vgendron

XLDnaute Barbatruc
Hello

Comme j'avais commencé, je finis :)
Vu que je préfère le formulaire de TheBenoit, j'ai "plus ou moins" reproduit le meme..
mais avec mon code.. plus rapide

Dans l'initialize, tu as juste à donner les noms de feuille Initiale et destination
Initiale = ta feuille "Commande Trains" (c'est drole.. il me semble qu'on travaillait sur des bus hier...)
et Destination: Soit Feuil3 pour garder ta feuille initiale intacte
Soit tu remets Commande Trains pour écraser la feuille source
au final.. je mets tout dans une table..
 

Pièces jointes

  • Outil_Compa TRAIN Rev 1.xlsm
    1.5 MB · Affichages: 26

thebenoit59

XLDnaute Accro
Pour proposer une version avec array, voici un autre code.
Les fonctions sont tirées du site de Boisgontier, la seconde est juste adaptée.

VB:
Private Sub UserForm_Initialize()
With Me
    .cbMod.List = Array("Modification Convoi", "Modification Horaire", "Modification Roulement", "Modification Parcours")
    .obHD1.Value = True
End With
End Sub

Private Sub cmdHeures_Click()
Dim heure As Date
Dim col As Byte
Dim comp$, pre$
Dim i&

With Me
    If Not IsDate(.tbHeure.Value) Then MsgBox "Inscrire l'horaire selon le format: hh:mm:ss": Exit Sub
    heure = .tbHeure.Value
    If .obHD1.Value Then
        col = 7
        Else
        col = 14
    End If
End With

With Sheets(3)
    a = .Range("A2:T" & .Cells.Find("*", , , , xlByRows, xlPrevious).Row).Value
    Select Case Me.cbPre.Value
        Case False
            a = FiltreArraySupLignesH(a, col, heure, "av")
        Case True
            a = FiltreArraySupLignesH(a, col, heure, "ap")
    End Select
    .Range("A2:T" & .Cells.Find("*", , , , xlByRows, xlPrevious).Row).ClearContents
    .[A2].Resize(UBound(a), UBound(a, 2)).Formula = a
End With

End Sub

Private Sub cmdMod_Click()
Dim i&, tModif$, a()

With Me
    If .cbMod.Value = "" Then Exit Sub
    tModif = .cbMod.Value
End With

With Sheets(3)
    a = .Range("A2:T" & .Cells.Find("*", , , , xlByRows, xlPrevious).Row).Value
    a = FiltreArraySupLignesMod(a, 18, tModif)
    .Range("A2:T" & .Cells.Find("*", , , , xlByRows, xlPrevious).Row).ClearContents
    .[A2].Resize(UBound(a), UBound(a, 2)).Formula = a
End With

End Sub

Function FiltreArraySupLignesMod(Tbl, col, cle)
  Dim i, n
  Dim tmp(): ReDim tmp(1 To UBound(Tbl))
  For i = LBound(Tbl) To UBound(Tbl)
    If Tbl(i, col) <> cle Then n = n + 1: tmp(n) = i
  Next
  ReDim Preserve tmp(1 To n)
  FiltreArraySupLignesMod = Application.Index(Tbl, Application.Transpose(tmp), _
  Application.Transpose(Evaluate("Row(1:" & UBound(Tbl, 2) & ")")))
End Function

Function FiltreArraySupLignesH(Tbl, col, cle, pre)
  Dim i, n
  Dim tmp(): ReDim tmp(1 To UBound(Tbl))
    Select Case pre
        Case "av"
            For i = LBound(Tbl) To UBound(Tbl)
                If Tbl(i, col) >= cle Then n = n + 1: tmp(n) = i
            Next i
        Case "ap"
            For i = LBound(Tbl) To UBound(Tbl)
                If Tbl(i, col) <= cle Then n = n + 1: tmp(n) = i
            Next i
    End Select
  ReDim Preserve tmp(1 To n)
  FiltreArraySupLignesH = Application.Index(Tbl, Application.Transpose(tmp), _
  Application.Transpose(Evaluate("Row(1:" & UBound(Tbl, 2) & ")")))
End Function
 

Pièces jointes

  • xlDown - Yann2702 - 2 Macro 1 Suppr. ligne et 1 Suppr. heure 2.xlsm
    1.6 MB · Affichages: 19

Yann2702

XLDnaute Nouveau
Pour proposer une version avec array, voici un autre code.
Les fonctions sont tirées du site de Boisgontier, la seconde est juste adaptée.

VB:
Private Sub UserForm_Initialize()
With Me
    .cbMod.List = Array("Modification Convoi", "Modification Horaire", "Modification Roulement", "Modification Parcours")
    .obHD1.Value = True
End With
End Sub

Private Sub cmdHeures_Click()
Dim heure As Date
Dim col As Byte
Dim comp$, pre$
Dim i&

With Me
    If Not IsDate(.tbHeure.Value) Then MsgBox "Inscrire l'horaire selon le format: hh:mm:ss": Exit Sub
    heure = .tbHeure.Value
    If .obHD1.Value Then
        col = 7
        Else
        col = 14
    End If
End With

With Sheets(3)
    a = .Range("A2:T" & .Cells.Find("*", , , , xlByRows, xlPrevious).Row).Value
    Select Case Me.cbPre.Value
        Case False
            a = FiltreArraySupLignesH(a, col, heure, "av")
        Case True
            a = FiltreArraySupLignesH(a, col, heure, "ap")
    End Select
    .Range("A2:T" & .Cells.Find("*", , , , xlByRows, xlPrevious).Row).ClearContents
    .[A2].Resize(UBound(a), UBound(a, 2)).Formula = a
End With

End Sub

Private Sub cmdMod_Click()
Dim i&, tModif$, a()

With Me
    If .cbMod.Value = "" Then Exit Sub
    tModif = .cbMod.Value
End With

With Sheets(3)
    a = .Range("A2:T" & .Cells.Find("*", , , , xlByRows, xlPrevious).Row).Value
    a = FiltreArraySupLignesMod(a, 18, tModif)
    .Range("A2:T" & .Cells.Find("*", , , , xlByRows, xlPrevious).Row).ClearContents
    .[A2].Resize(UBound(a), UBound(a, 2)).Formula = a
End With

End Sub

Function FiltreArraySupLignesMod(Tbl, col, cle)
  Dim i, n
  Dim tmp(): ReDim tmp(1 To UBound(Tbl))
  For i = LBound(Tbl) To UBound(Tbl)
    If Tbl(i, col) <> cle Then n = n + 1: tmp(n) = i
  Next
  ReDim Preserve tmp(1 To n)
  FiltreArraySupLignesMod = Application.Index(Tbl, Application.Transpose(tmp), _
  Application.Transpose(Evaluate("Row(1:" & UBound(Tbl, 2) & ")")))
End Function

Function FiltreArraySupLignesH(Tbl, col, cle, pre)
  Dim i, n
  Dim tmp(): ReDim tmp(1 To UBound(Tbl))
    Select Case pre
        Case "av"
            For i = LBound(Tbl) To UBound(Tbl)
                If Tbl(i, col) >= cle Then n = n + 1: tmp(n) = i
            Next i
        Case "ap"
            For i = LBound(Tbl) To UBound(Tbl)
                If Tbl(i, col) <= cle Then n = n + 1: tmp(n) = i
            Next i
    End Select
  ReDim Preserve tmp(1 To n)
  FiltreArraySupLignesH = Application.Index(Tbl, Application.Transpose(tmp), _
  Application.Transpose(Evaluate("Row(1:" & UBound(Tbl, 2) & ")")))
End Function

Merci à vous deux pour votre superbe travail c'est impressionnant ce qu'on peut faire en connaissant bien le VBA... Je suis personnelement en attente de formation depuis longtemps... et pourtant ça me serait utile...

Merci encore. Et puis j'aurais surement d'autre demande :p
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 949
Membres
101 851
dernier inscrit
vaiata