XL 2019 Ne pas faire apparaitre des lignes vides

[Tarrain]

Bonjour,

j'ai fait un petit fichier avec un onglet avec des données et je souhaite dans un autre onglet faire des etiquettes et une liste en fonction des données rentrées, pas de soucis jusque là mais quand je fais mes etiquettes ou ma liste je souhaiterai que les lignes sans données n'apparaissent pas car dans données je me suis laissé la possibilité dans rajouter ou enlever au besoin.

Mieux qu'un grand discours, je vous envoie en FJ unbout de mon fichier
J'ai remis une petite explication dans le deuxieme onglet etiquette qui vaut aussi pour l'onglet liste

Merci pour votre aide

Seb

 

[job75]

Bonjour Tarrain,

La macro dans la feuille Etiquettes :

Private Sub Worksheet_Activate()
Dim tablo(), c As Range, n&, c1 As Range
ReDim tablo(1 To Rows.Count, 1 To 1) 'matrice, plus rapide
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
On Error Resume Next 'si aucune SpecialCell
Range("B3:B" & Rows.Count).Clear 'RAZ
For Each c In Sheets("données").Columns(1).SpecialCells(xlCellTypeConstants)
    If c <> "" Then
        n = 0
        For Each c1 In c(1, 2).Resize(c.MergeArea.Count).SpecialCells(xlCellTypeConstants)
            n = n + 1
            tablo(n, 1) = c1(1, 2) & c1
        Next c1
        Set c1 = Range("B" & Rows.Count).End(xlUp)(2)
        If c1.Row < 3 Then Set c1 = Range("B3")
        c1.Resize(n) = tablo
        c1.Resize(n).Font.Color = c.Font.Color 'couleur police
    End If
Next c
End Sub

La macro dans la feuille Liste, très voisine :

Private Sub Worksheet_Activate()
Dim tablo(), c As Range, n&, c1 As Range
ReDim tablo(1 To Rows.Count, 1 To 1) 'matrice, plus rapide
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
On Error Resume Next 'si aucune SpecialCell
Range("B3:B" & Rows.Count).Clear 'RAZ
For Each c In Sheets("données").Columns(1).SpecialCells(xlCellTypeConstants)
    If c <> "" Then
        n = 0
        For Each c1 In c(1, 2).Resize(c.MergeArea.Count).SpecialCells(xlCellTypeConstants)
            n = n + 1
            tablo(n, 1) = c1(1, 2) & c1
        Next c1
        Set c1 = Range("B" & Rows.Count).End(xlUp)(3)
        If c1.Row < 5 Then Set c1 = Range("B5")
        c1(0) = c 'nom de la couleur
        c1.Resize(n) = tablo
        c1.Resize(n).Font.Color = c.Font.Color 'couleur police
    End If
Next c
End Sub

A+

 

[Tarrain]

il faut que je les lance les macros ou elles se lancent toutes seuls , j.ai reine à faire ?
je regarde cela dès que je rentre et je vous dis si cela fait mon affaire, déjà un Grand merci

 

[job75]

Les macros se déclenchent automatiquement quand on active les feuilles.

Dans ce fichier (2) je les ai légèrement modifiées, feuille Etiquettes :

Private Sub Worksheet_Activate()
Dim tablo(), c As Range, n&, c1 As Range
ReDim tablo(1 To Rows.Count, 1 To 1) 'matrice, plus rapide
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
On Error Resume Next 'si aucune SpecialCell
Range("B3:B" & Rows.Count).Clear 'RAZ
For Each c In Sheets("données").Columns(1).SpecialCells(xlCellTypeConstants)
    If c <> "" Then
        n = 0
        For Each c1 In c(1, 2).Resize(c.MergeArea.Count)
            If c1 <> "" Then
                n = n + 1
                tablo(n, 1) = c1(1, 2) & c1
            End If
        Next c1
        Set c1 = Range("B" & Rows.Count).End(xlUp)(2)
        If c1.Row < 3 Then Set c1 = Range("B3")
        c1.Resize(n) = tablo
        c1.Resize(n).Font.Color = c.Font.Color 'couleur police
    End If
Next c
End Sub

Feuille Liste :

Private Sub Worksheet_Activate()
Dim tablo(), c As Range, n&, c1 As Range
ReDim tablo(1 To Rows.Count, 1 To 1) 'matrice, plus rapide
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
On Error Resume Next 'si aucune SpecialCell
Range("B3:B" & Rows.Count).Clear 'RAZ
For Each c In Sheets("données").Columns(1).SpecialCells(xlCellTypeConstants)
    If c <> "" Then
        n = 0
        For Each c1 In c(1, 2).Resize(c.MergeArea.Count)
            If c1 <> "" Then
                n = n + 1
                tablo(n, 1) = c1(1, 2) & c1
            End If
        Next c1
        Set c1 = Range("B" & Rows.Count).End(xlUp)(3)
        If c1.Row < 5 Then Set c1 = Range("B5")
        c1(0) = c 'nom de la couleur
        c1.Resize(n) = tablo
        c1.Resize(n).Font.Color = c.Font.Color 'couleur police
    End If
Next c
End Sub

Le fichier (1) présentait un petit défaut quand on effaçait par exemple B3:B6.

 

[Tarrain]

je viens de rgarder ca à l'air super par contre je voulais regarder les macros pas a pas mais dans macro je ne les vois pas -
je souhaitai modifier car là j'ai le prénom collé au nom
je souhaitai rajouter des lignes à la fin de chaque groupe ( j'en voulai 15 par groupe
je souhaitai mettre au moins deux lignes au dessus des couleurs pour séparer dans l'onglet liste
encore merci

 

[job75]

Fichier (3) qui sépare prénom et nom ainsi que les couleurs dans la feuille "Liste".

J'ai mis aussi 15 lignes par couleur dans la feuille "Données", là on fait ce qu'on veut.

 

[Tarrain]

Ah super MERCI beaucoup