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

Yann2702 · 19 Décembre 2017

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.

vgendron · 19 Décembre 2017

Ton fichier est verrouillé. on ne peut pas voir les macros et donc les modifier

Yann2702 · 19 Décembre 2017

vgendron à dit:
Ton fichier est verrouillé. on ne peut pas voir les macros et donc les modifier

Excuses moi le mot de passe est PCATLC

thebenoit59 · 20 Décembre 2017

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 · 20 Décembre 2017

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..

thebenoit59 · 20 Décembre 2017

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

vgendron · 20 Décembre 2017

et pour finir.. avec les MFC reproduites !

vgendron · 20 Décembre 2017

Hello TheBenoit59 :-D

on s'amuse bien n'est ce pas :-D

thebenoit59 · 20 Décembre 2017

Il faut bien en fin d'année

Yann2702 · 22 Décembre 2017

thebenoit59 à dit:

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

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

Yann2702

XLDnaute Nouveau

Pièces jointes

vgendron

XLDnaute Barbatruc

Yann2702

XLDnaute Nouveau

thebenoit59

XLDnaute Accro

vgendron

XLDnaute Barbatruc

Pièces jointes

thebenoit59

XLDnaute Accro

Pièces jointes

vgendron

XLDnaute Barbatruc

Pièces jointes

vgendron

XLDnaute Barbatruc

thebenoit59

XLDnaute Accro

Yann2702

XLDnaute Nouveau

Discussions similaires