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

Y

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
Trier par date Trier par votes
T

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.
 
Vote positif 0 Vote négatif
vgendron

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
Vote positif 0 Vote négatif
T

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
Vote positif 0 Vote négatif
Y

Yann2702

XLDnaute Nouveau
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
Cliquez pour agrandir...

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
 
Vote positif 0 Vote négatif

Discussions similaires

S
  • Question
XL 2010 VBA - macro avec 1 boucle qui alterne 1 action à conditions et 1 action sans conditions
2 3 4
Réponses
58
Affichages
7 K
Scorp0211
S
D
  • Question
Microsoft 365 Formule / VBA tableau : nom de ligne et délais par créneau
Réponses
6
Affichages
1 K
njhub
N
D
  • Question
XL 2016 Trier en fonction de la date et mettre les element en pdf
Réponses
0
Affichages
638
djidji225
D
D
  • Question
Macro insertin ligne avec mot et heure
Réponses
2
Affichages
437
DJARNAUD
D
F
  • Question
Optimisation de macro et correction de MEF conditionnel
Réponses
4
Affichages
1 K
fredd
F
N
  • Question
Booster une macro
Réponses
5
Affichages
3 K
Staple1600
Staple1600
A
  • Question
Rassembler et optimiser 2 codes VBA (exporter données et suppimer val numériques)
Réponses
9
Affichages
1 K
Amilo
A
M
  • Question
Rapatrier des données de plusieurs fichiers dans un seul fichier et sous conditions
2
Réponses
16
Affichages
15 K
Staple1600
Staple1600
S
  • Question
Macro inserer ligne, supprimer ligne en fonction taille tcd
2 3
Réponses
33
Affichages
5 K
chris
chris
D
  • Question
Macro rechercher puis insérer ou supprimer ligne
Réponses
12
Affichages
9 K
dav123
D

Membres actuellement en ligne

12 membres et 88 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 080
Messages
2 116 019
Membres
112 637
dernier inscrit
pseudoinconnu