Vide Copie de la ligne entière dans un nouvel onglet

Bonjour à tous,

Je viens vers vous car je ne trouve pas solution à mon problème et comme je ne suis pas un grand expert en VBA voilà.

J'ai un classeur avec 10 colonnes parfois dans la colonne A il y a des cellules vides et les 9 autres sont bien remplis. J'ai besoin que si en colonne A une cellule où plusieurs ses vides un nouvel onglet soit créé si celui-ci n'existe pas et colle la ligne entière où se trouve la cellule vide. Et une fois copié il supprime les lignes dans l'onglet MM après macro

je vous joins un fichier exemple la MM avant Macro et ma base et MM après macro et cellule vide est le résultat attendu

merci a tout pour votre aide

Jérôme

Bonsoir xbosster, bonsoir le forum,

Essaie comme ça (nom des onglets à adapter dans le code) :

Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OC As Worksheet 'déclare la variable OC (Onglet Copie)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim LI As Integer 'déclare la variable LI (Ligne)
Dim PL As Range 'déclare la variable PL (PLage)

Set OS = Worksheets("Base") 'définit l'onglet OS (à adapter à ton cas)
Set PL = OS.Range("A1") 'initialise la plage PL
On Error Resume Next 'gestion des errerus (en cas d'erreur passe a la ligne suivante)
Set OC = Worksheets("Copie") 'définit l'onglet OC (génère une erreur si cet onglet n'existe pas) <= ici
If Err > 0 Then 'condition : si une erreur a été générée
    Err.Clear 'supprime l'erreur
    OS.Copy after:=OS 'copy l'onglet OS après lui-même
    Set OC = ActiveSheet 'défiit l'onglet OC
    OC.Name = "Copie" 'renomme l'onglet OC (à adapter de manière cohérente avec la ligne indiquée "ici")
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
OC.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'vide d'éventuelles anciennes données dans l'onglet OC
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 1) = "" Then Set PL = IIf(PL.Cells.Count = 1, OS.Rows(I), Application.Union(PL, OS.Rows(I))) 'si la donnée ligne I colonne 1 de TV est vide, définit la plage PL
Next I 'prochaine ligne de la boucle
PL.Copy OC.Range("A2") 'copie la plage PL dans la cellule A2 de l'onglet OC
PL.Delete 'supprime la plage PL
End Sub

Re,

Essaie comme ça alors :

Sub Macro1()
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim OC As Worksheet 'déclare la variable OC (Onglet Copie)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim LI As Integer 'déclare la variable LI (Ligne)
Dim PL As Range 'déclare la variable PL (PLage)

Set OS = Worksheets("Base") 'définit l'onglet OS (à adapter à ton cas)
Set PL = OS.Range("A1") 'initialise la plage PL
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 1) = "" Then Set PL = IIf(PL.Cells.Count = 1, OS.Rows(I), Application.Union(PL, OS.Rows(I))) 'si la donnée ligne I colonne 1 de TV est vide, définit la plage PL
Next I 'prochaine ligne de la boucle
If PL.Cells.Count = 1 Then
    Exit Sub
Else
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe a la ligne suivante)
    Set OC = Worksheets("Copie") 'définit l'onglet OC (génère une erreur si cet onglet n'existe pas) <= ici
    If Err > 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        OS.Copy after:=OS 'copy l'onglet OS après lui-même
        Set OC = ActiveSheet 'définit l'onglet OC
        OC.Name = "Copie" 'renomme l'onglet OC (à adapter de manière cohérente avec la ligne indiquée "ici")
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    OC.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'vide d'éventuelles anciennes données dans l'onglet OC
    PL.Copy OC.Range("A2") 'copie la plage PL dans la cellule A2 de l'onglet OC
    PL.Delete 'supprime la plage PL
End If
End Sub

Salut ThauThème,

Un grand merci a toi ça fonctionne parfaitement

Re ThauThème,

Je viens de voir un petit souci. Quand il n'y a pas de cellule vide en colonne A la macro empêche la macro suivante de se lancer elle me permet de crée mes onglets par à port à la cellule A. Par contre quand il y a bien des cellules vides en A pas de souci tout fonctionne correctement.

merci pour ton aide

Jérôme

Bonsoir

xbooster a écrit :

Je viens de voir un petit souci. Quand il n'y a pas de cellule vide en colonne A la macro empêche la macro suivante de se lancer...

Quelle macro suivante ?!...

Salut ThauThème,

Voilà les deux macros qui tournent cellule vide et celle que tu as créée et cellule onglet doit se lancer juste après.

Merci pour ton aide

Jérôme

Sub Macro1()
Application.ScreenUpdating = False
Dim FEUILLE_DEST As Worksheet
Dim var As Object
Dim Plage As Range
Dim Cell As Range
Dim I As Long
Dim Base As Range
Dim OS As Worksheet 
Dim OC As Worksheet 
Dim TV As Variant 
Dim LI As Integer
Dim PL As Range

''''DEBUT cellule vide''''
Set OS = Worksheets("BASE") 'définit l'onglet OS (à adapter à ton cas)
Set PL = OS.Range("A1") 'initialise la plage PL
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 1) = "" Then Set PL = IIf(PL.Cells.Count = 1, OS.Rows(I), Application.Union(PL, OS.Rows(I))) 'si la donnée ligne I colonne 1 de TV est vide, définit la plage PL
Next I 'prochaine ligne de la boucle
If PL.Cells.Count = 1 Then
    Exit Sub
Else
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe a la ligne suivante)
    Set OC = Worksheets("copie") 'définit l'onglet OC (génère une erreur si cet onglet n'existe pas) <= ici
    If Err > 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        OS.Copy after:=OS 'copy l'onglet OS après lui-même
        Set OC = ActiveSheet 'définit l'onglet OC
        OC.Name = "copie" 'renomme l'onglet OC (à adapter de manière cohérente avec la ligne indiquée "ici")
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    OC.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'vide d'éventuelles anciennes données dans l'onglet OC
    PL.Copy OC.Range("A2") 'copie la plage PL dans la cellule A2 de l'onglet OC
    PL.Delete 'supprime la plage PL
End If

''''FIN cellule vide'''''

''''DEBUT Cellule en onglet''''
Data = "Base" 'nom de la feuille des données

' création de l'objet SortedList
Set var = CreateObject("System.Collections.SortedList")

With ThisWorkbook.Worksheets(Data).Cells(1, 1)
    Set Plage = .CurrentRegion  ' plage des données (avec les titres)
    For Each Cell In .CurrentRegion.Columns(1).Cells   ' boucle pour créer la liste sans doublon
        If Not var.containskey(Cell.Value) And Cell.Row > 1 Then
            var.Add Cell.Value, Cell.Text
        End If
    Next Cell
End With

For I = 0 To var.Count - 1

    ' ici on gère le fait que la feuille existe ou non
    On Error Resume Next
        Set FEUILLE_DEST = ThisWorkbook.Worksheets(var.getbyindex(I))
    On Error GoTo 0

    ' si la feuille n'existe pas : on la crée et la renomme avec le nom de la var
    If FEUILLE_DEST Is Nothing Then
        Set FEUILLE_DEST = ThisWorkbook.Worksheets.Add
        FEUILLE_DEST.Name = var.getbyindex(I)
        FEUILLE_DEST.Move after:=Sheets(ActiveWorkbook.Sheets.Count)

    ' si la feuille existe : on efface tout
    Else
        FEUILLE_DEST.Cells.Clear
    End If

    With FEUILLE_DEST
        .Cells(1, 1) = Plage.Cells(1, 1)
        .Cells(2, 1) = var.getbyindex(I)
        Plage.AdvancedFilter xlFilterCopy, .Cells(1, 1).CurrentRegion, .Cells(4, 1), False
        .Cells(1, 1).Resize(3, 1).EntireRow.Delete
    End With

    Set FEUILLE_DEST = Nothing
Next I

Application.ScreenUpdating = True

Workbooks("test.xlsm").Save

''''FIN Cellule en onglet''''
End Sub

Re,

J'ai rajouté un goto avec une étiquette suite :

Option Explicit

Sub Macro1()
Application.ScreenUpdating = False
Dim FEUILLE_DEST As Worksheet
Dim var As Object
Dim Plage As Range
Dim Cell As Range
Dim I As Long
Dim Base As Range
Dim OS As Worksheet
Dim OC As Worksheet
Dim TV As Variant
Dim LI As Integer
Dim PL As Range

''''DEBUT cellule vide''''
Set OS = Worksheets("BASE") 'définit l'onglet OS (à adapter à ton cas)
Set PL = OS.Range("A1") 'initialise la plage PL
TV = OS.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 1) = "" Then Set PL = IIf(PL.Cells.Count = 1, OS.Rows(I), Application.Union(PL, OS.Rows(I))) 'si la donnée ligne I colonne 1 de TV est vide, définit la plage PL
Next I 'prochaine ligne de la boucle
If PL.Cells.Count = 1 Then
    GoTo suite '<====== étiquette
Else
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe a la ligne suivante)
    Set OC = Worksheets("copie") 'définit l'onglet OC (génère une erreur si cet onglet n'existe pas) <= ici
    If Err > 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        OS.Copy after:=OS 'copy l'onglet OS après lui-même
        Set OC = ActiveSheet 'définit l'onglet OC
        OC.Name = "copie" 'renomme l'onglet OC (à adapter de manière cohérente avec la ligne indiquée "ici")
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    OC.Range("A1").CurrentRegion.Offset(1, 0).ClearContents 'vide d'éventuelles anciennes données dans l'onglet OC
    PL.Copy OC.Range("A2") 'copie la plage PL dans la cellule A2 de l'onglet OC
    PL.Delete 'supprime la plage PL
End If

suite: 'étiquette
Data = "Base" 'nom de la feuille des données
' création de l'objet SortedList
Set var = CreateObject("System.Collections.SortedList")
With ThisWorkbook.Worksheets(Data).Cells(1, 1)
    Set Plage = .CurrentRegion  ' plage des données (avec les titres)
    For Each Cell In .CurrentRegion.Columns(1).Cells   ' boucle pour créer la liste sans doublon
        If Not var.containskey(Cell.Value) And Cell.Row > 1 Then
            var.Add Cell.Value, Cell.Text
        End If
    Next Cell
End With
For I = 0 To var.Count - 1
    ' ici on gère le fait que la feuille existe ou non
    On Error Resume Next
        Set FEUILLE_DEST = ThisWorkbook.Worksheets(var.getbyindex(I))
    On Error GoTo 0
    ' si la feuille n'existe pas : on la crée et la renomme avec le nom de la var
    If FEUILLE_DEST Is Nothing Then
        Set FEUILLE_DEST = ThisWorkbook.Worksheets.Add
        FEUILLE_DEST.Name = var.getbyindex(I)
        FEUILLE_DEST.Move after:=Sheets(ActiveWorkbook.Sheets.Count)
    ' si la feuille existe : on efface tout
    Else
        FEUILLE_DEST.Cells.Clear
    End If
    With FEUILLE_DEST
        .Cells(1, 1) = Plage.Cells(1, 1)
        .Cells(2, 1) = var.getbyindex(I)
        Plage.AdvancedFilter xlFilterCopy, .Cells(1, 1).CurrentRegion, .Cells(4, 1), False
        .Cells(1, 1).Resize(3, 1).EntireRow.Delete
    End With
    Set FEUILLE_DEST = Nothing
Next I
Application.ScreenUpdating = True
Workbooks("test.xlsm").Save
End Sub