XL 2019 Aide modification vba

Fanrs · 9 Avril 2021

Bonjour,

J'ai ce code vba (ci-dessous) qui marche très bien pour supprimer les lignes en doubles dont les cellules, jusqu'à la colonne 15, sont identiques.

Malheureusement, cela marche sur un tableau commençant à la ligne 1 jusqu'a la fin, mais pas sur un tableau commençant à la ligne 7... Est-ce que quelqu'un peut me le modifier pour qu'il soit fonctionnement de la ligne 7 jusqu'a la fin ?

VB:

Dim i As Long, LigFin As Long
Dim j As Integer
Const NbCol = 5     'Nombre de colonnes
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
With Sheets("Feuil1")                   'A adapter
    .Rows(1).Insert
    For j = 1 To NbCol
        .Cells(1, j) = Chr(65 + j)
    Next j
    LigFin = .Cells(Rows.Count, 1).End(xlUp).Row
        If .FilterMode Then .ShowAllData
            .Range(.Cells(1, 1), .Cells(LigFin, NbCol)).AdvancedFilter xlFilterInPlace, , , True
            For i = LigFin To 2 Step -1
                If .Rows(i).Hidden And Application.CountBlank(.Range(.Cells(i, 1), .Cells(i, NbCol))) <> NbCol Then .Rows(i).Delete
            Next i
         If .FilterMode Then .ShowAllData
    .Rows(1).Delete
End With
Application.DisplayAlerts = True

Et à côté de ça, est-il possible au lieu de supprimer les lignes en doubles de les masquer ?

Merci d'avance

Bernard_XLD · 9 Avril 2021

sinon essayes aussi comme cela

VB:

Dim i As Long, LigFin As Long
Dim j As Integer, Cells_Masque As Range, Cel_en_Cours As Range
Const NbCol = 5     'Nombre de colonnes
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheets("Feuil1")                   'A adapter
    .Rows(7).Insert
    For j = 1 To NbCol
        .Cells(7, j) = Chr(65 + j)
    Next j
    LigFin = .Cells(Rows.Count, 1).End(xlUp).Row
    If .FilterMode Then .ShowAllData
    .Range(.Cells(7, 1), .Cells(LigFin, NbCol)).AdvancedFilter xlFilterInPlace, , , True
    For i = LigFin To 8 Step -1
        If .Rows(i).Hidden And Application.CountBlank(.Range(.Cells(i, 1), .Cells(i, NbCol))) <> NbCol Then '.Rows(i).Delete
            If Cells_Masque Is Nothing...

JBARBE · 9 Avril 2021

Bonjour à tous,
Peut-être ceci :
Bonne journée !

VB:

Dim i As Long, LigFin As Long
Dim j As Integer
Const NbCol = 5     'Nombre de colonnes
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
With Sheets("Feuil1")                   'A adapter
    .Rows(1).Insert
    For j = 7 To NbCol
        .Cells(1, j) = Chr(65 + j)
    Next j
    LigFin = .Cells(Rows.Count, 1).End(xlUp).Row
        If .FilterMode Then .ShowAllData
            .Range(.Cells(1, 1), .Cells(LigFin, NbCol)).AdvancedFilter xlFilterInPlace, , , True
            For i = LigFin To 2 Step -1
                If .Rows(i).Hidden And Application.CountBlank(.Range(.Cells(i, 1), .Cells(i, NbCol))) <> NbCol Then .Rows(i).Delete
            Next i
         If .FilterMode Then .ShowAllData
    .Rows("1:1").EntireRow.Hidden = True
End With
Application.DisplayAlerts = True

Fanrs · 9 Avril 2021

Merci pour ta réponse et proposition, mais malheureusement ça me fait des trucs bizarre sur la première ligne et aucune suppression de doublon

Bernard_XLD · 9 Avril 2021

Bonjour Fanrs, JBARBE, le forum

en faisant simple, cela devrait fonctionner

Cordialement, @+

VB:

Dim i As Long, LigFin As Long
Dim j As Integer
Const NbCol = 5     'Nombre de colonnes
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
With Sheets("Feuil1")                   'A adapter
    .Rows(7).Insert
    For j =1 To NbCol
        .Cells(7, j) = Chr(65 + j)
    Next j
    LigFin = .Cells(Rows.Count, 1).End(xlUp).Row
        If .FilterMode Then .ShowAllData
            .Range(.Cells(7, 1), .Cells(LigFin, NbCol)).AdvancedFilter xlFilterInPlace, , , True
            For i = LigFin To 8 Step -1
                If .Rows(i).Hidden And Application.CountBlank(.Range(.Cells(i, 1), .Cells(i, NbCol))) <> NbCol Then .Rows(i).Delete
            Next i
         If .FilterMode Then .ShowAllData
    .Rows(7).Delete
End With
Application.DisplayAlerts = True

Bernard_XLD · 9 Avril 2021

Fanrs à dit:
Et à côté de ça, est-il possible au lieu de supprimer les lignes en doubles de les masquer ?

je n'avais pas vu ta dernière demande
pas testé faute de fichier mais ça devrait fonctionner

[édition: code modifié]
Bien cordialement

Code:

Dim i As Long, LigFin As Long
Dim j As Integer, Cells_Masque As Range
Const NbCol = 5     'Nombre de colonnes
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheets("Feuil1")                   'A adapter
    .Rows(7).Insert
    For j = 1 To NbCol
        .Cells(7, j) = Chr(65 + j)
    Next j
    LigFin = .Cells(.Rows.Count, 1).End(xlUp).Row
        If .FilterMode Then .ShowAllData
            .Range(.Cells(7, 1), .Cells(LigFin, NbCol)).AdvancedFilter xlFilterInPlace, , , True
            For i = LigFin To 8 Step -1
                If .Rows(i).Hidden And Application.CountBlank(.Range(.Cells(i, 1), .Cells(i, NbCol))) <> NbCol Then '.Rows(i).Delete
                    If Cells_Masque Is Nothing Then
                        Set Cells_Masque = .Range("A" & i)
                    Else
                        Set Cells_Masque = Application.Union(Cells_Masque, .Range("A" & i))
                    End If
                End If
            Next i
         If .FilterMode Then .ShowAllData
    If Not Cells_Masque Is Nothing Then Cells_Masque.EntireRow.Hidden = True: Set Cells_Masque = Nothing
    .Rows(7).Delete
End With
Application.DisplayAlerts = True

Fanrs · 9 Avril 2021

Merci pour ton aide,

Pour supprimer les lignes ça à l'air d'être ok
Pour masquer les lignes j'ai une erreur Cells_Masque.EntireRow.Delete Shift:=xlUp

Bernard_XLD · 9 Avril 2021

re essayes, j'ai modifié le dernier code
sinon mets un fichier exemple

Bernard_XLD · 9 Avril 2021

sinon essayes aussi comme cela

VB:

Dim i As Long, LigFin As Long
Dim j As Integer, Cells_Masque As Range, Cel_en_Cours As Range
Const NbCol = 5     'Nombre de colonnes
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Sheets("Feuil1")                   'A adapter
    .Rows(7).Insert
    For j = 1 To NbCol
        .Cells(7, j) = Chr(65 + j)
    Next j
    LigFin = .Cells(Rows.Count, 1).End(xlUp).Row
    If .FilterMode Then .ShowAllData
    .Range(.Cells(7, 1), .Cells(LigFin, NbCol)).AdvancedFilter xlFilterInPlace, , , True
    For i = LigFin To 8 Step -1
        If .Rows(i).Hidden And Application.CountBlank(.Range(.Cells(i, 1), .Cells(i, NbCol))) <> NbCol Then '.Rows(i).Delete
            If Cells_Masque Is Nothing Then
                Set Cells_Masque = .Range("A" & i)
            Else
                Set Cells_Masque = Application.Union(Cells_Masque, .Range("A" & i))
            End If
        End If
    Next i
    If .FilterMode Then .ShowAllData
    If Not Cells_Masque Is Nothing Then
        For Each Cel_en_Cours In Cells_Masque
            Cel_en_Cours.EntireRow.Hidden = True
        Next Cel_en_Cours
        Set Cells_Masque = Nothing
    End If
    .Rows(7).Delete
End With
Application.DisplayAlerts = True

Fanrs · 9 Avril 2021

Parfait, merci !

Bernard_XLD · 9 Avril 2021

Si tu rencontres d'autres problèmes, essayes de faire un fichier exemple simple et anonymisé, c'est beaucoup plus facile pour les contributeurs quand on peut tester qu'avec juste un code.

Bonne continuation, @+

Fanrs · 9 Avril 2021

Yeahou à dit:
Si tu rencontres d'autres problèmes, essayes de faire un fichier exemple simple et anonymisé, c'est beaucoup plus facile pour les contributeurs quand on peut tester qu'avec juste un code.

Bonne continuation, @+

Merci pour le conseil, mais surtout pour l'aide.... c'est grâce à des gens comme vous que l'on peut avancer et peut être un jour, je retournerai pour d'autre personnes...

Chaque aide est peut-être la création d'une chaine d'aide

Merci

XL 2019 Aide modification vba

Fanrs

XLDnaute Nouveau

Bernard_XLD

JBARBE

XLDnaute Barbatruc

Fanrs

XLDnaute Nouveau

Bernard_XLD

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

Fanrs

XLDnaute Nouveau

Bernard_XLD

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

Fanrs

XLDnaute Nouveau

Bernard_XLD

XLDnaute Barbatruc

Fanrs

XLDnaute Nouveau

Discussions similaires