Microsoft 365 Dupliquer des lignes dans une autre feuille avec une condition

[de_hanstrapp]

Bonsoir le forum,

Je cherche à dupliquer toutes les lignes de mon tableau qui répondent à une condition dans une autre feuille de mon classeur.

Actuellement, j'utilise le code VBA suivant mais il a un délais de réponse plutôt long...
Est-il possible d'optimiser la durée du traitement ?


Sub ExportAA()

Dim Lig As Long
Dim Col As String
Dim NbrLig As Long
Dim NumLig As Long

Sheets("VILLE").Activate

Col = "H"
NumLig = 0
With Sheets("MATRICE")
NbrLig = .Cells(65536, Col).End(xlUp).Row
For Lig = 1 To NbrLig
If .Cells(Lig, Col).Value = "VILLE - Athènes" Then
.Cells(Lig, Col).EntireRow.Copy
NumLig = NumLig + 1
Cells(NumLig, 1).Select
ActiveSheet.Paste
End If
Next
End With

End Sub


Merci par avance pour votre aide.
Bonne soirée,

de_hanstrapp

 

[Jacky67]

Bonsoir le forum,
Est-il possible d'optimiser la durée du traitement ?

de_hanstrapp

Bonjour,
Une proposition avec un filtre, et une ligne de titre
Mais sans classeur test.......

Sub ExportAA()
    Sheets("VILLE").Activate
    ActiveSheet.UsedRange.Clear
    With Sheets("MATRICE").UsedRange
        .AutoFilter Field:=8, Criteria1:="VILLE - Athènes"
        .SpecialCells(xlCellTypeVisible).Copy [a1]
        .AutoFilter
    End With
End Sub

 

[de_hanstrapp]

Bonjour,
Une proposition avec un filtre, et une ligne de titre
Mais sans classeur test.......

Sub ExportAA()
    Sheets("VILLE").Activate
    ActiveSheet.UsedRange.Clear
    With Sheets("MATRICE").UsedRange
        .AutoFilter Field:=8, Criteria1:="VILLE - Athènes"
        .SpecialCells(xlCellTypeVisible).Copy [a1]
        .AutoFilter
    End With
End Sub

Merci Jacky67 c'est parfait et bcp bcp plus rapide !
Bonne journée.
de_hanstrapp

 

[de_hanstrapp]

Re-bonjour Jacky67,

J'ai modifié un peu l'architecture de la feuille "MATRICE" et je voulais savoir comment faire pour que dans l'export vers la feuille "AA" seuls les resultats filtrés pouvaient être collés car l'idée étant que les lignes de 1 à 10 restent les mêmes et ne soient jamais supprimées à l'activation de la macro.

Merci pour ton aide...

de_hanstrapp

 

[Jacky67]

Re-bonjour Jacky67,

J'ai modifié un peu l'architecture de la feuille "MATRICE" et je voulais savoir comment faire pour que dans l'export vers la feuille "AA" seuls les resultats filtrés pouvaient être collés car l'idée étant que les lignes de 1 à 10 restent les mêmes et ne soient jamais supprimées à l'activation de la macro.

Merci pour ton aide...

de_hanstrapp

Re...
D'où l'intérêt de joindre un classeur avec la structure définitive...
Avec le classeur test

 

[de_hanstrapp]

Re...
D'où l'intérêt de joindre un classeur avec la structure définitive...
Avec le classeur test

Bonsoir à tous,
Bonsoir Jacky67,

Je me permets de revenir vers vous pour savoir si, via le classeur test créé par vos soins, il serait envisageable avec le même critère :

With Sheets("MATRICE").[a10].CurrentRegion
.AutoFilter Field:=8, Criteria1:="VILLE - Athènes"
.SpecialCells(xlCellTypeVisible).Copy [a11]
.AutoFilter
End With

au lieu de l'enregistrer dans l'onglet "VILLE" de l'exporter dans un nouveau classeur .xlsx (sans liens, sans menus déroulants, ni formules mais avec la même mise en page), nommé en fonction du critère (ici : VILLE - Athènes) et un emplacement d'enregistrement à sélectionner manuellement lors de chaque opération ?

Merci pour votre aide.

de_hanstrapp

 

[chaelie2015]

Bonjour tout le monde
Voici une proposition qui utilise un tableau de variantes pour stocker les lignes qui répondent à la condition, puis copie ces lignes en une seule opération :

Sub ExportAA()

    Dim Lig As Long
    Dim Col As String
    Dim NbrLig As Long
    Dim NumLig As Long
    Dim CopyRows() As Variant
    Dim DestSheet As Worksheet

    ' Définir la feuille de destination
    Set DestSheet = Sheets("AutreFeuille") ' Remplacez "AutreFeuille" par le nom de votre feuille de destination

    Col = "H"
    NumLig = 0
    With Sheets("MATRICE")
        NbrLig = .Cells(65536, Col).End(xlUp).Row
        ReDim CopyRows(1 To NbrLig, 1 To .UsedRange.Columns.Count)
        
        For Lig = 1 To NbrLig
            If .Cells(Lig, Col).Value = "VILLE - Athènes" Then
                NumLig = NumLig + 1
                For ColNum = 1 To .UsedRange.Columns.Count
                    CopyRows(NumLig, ColNum) = .Cells(Lig, ColNum).Value
                Next ColNum
            End If
        Next Lig
    End With
    
    If NumLig > 0 Then
        DestSheet.Cells.Clear ' Effacer le contenu précédent dans la feuille de destination
        DestSheet.Cells(1, 1).Resize(NumLig, UBound(CopyRows, 2)).Value = CopyRows
    End If

End Sub

A+

 

[de_hanstrapp]

Bonsoir chaelie2015, le forum,

Je ne suis pas certain que mes explications précédentes étaient claires.
J'ai essayé d'avance... un peu...

Sub ExportAthènes()
    Worksheets("MASQUE").Copy After:=Sheets("MATRICE")
    ActiveSheet.Name = "RECAP"
    With Sheets("MATRICE").[b10].CurrentRegion
        .AutoFilter Field:=8, Criteria1:="VILLE - Athènes"
        .SpecialCells(xlCellTypeVisible).Copy [b11]
        .AutoFilter
    End With
    Worksheets("RECAP").Move
End Sub

La marco fonctionne, mais j'aimerais qu'elle me permette d'enregistrer le nouveau fichier à l'emplacement de mon choix mais en l'appelant par le contenu de la cellule "I11" de l'onglet "RECAP" (je n'ai pas trouvé le code qui va bien...).

Par ailleurs, plutôt que de dupliquer la macro x le nombre de villes mentionnées dans le tableau est il possible de faire le choix via un userform par exemple et l'export pourrait se faire avec un bouton intégré ?

Merci par avance pour vos conseils et aides.

de_hanstrapp

 

[chaelie2015]

Bonsoir
Essaie ce code.
Ce code va demander à l'utilisateur de choisir l'emplacement et le nom du nouveau fichier Excel à enregistrer. Il va utiliser le contenu de la cellule "I11" de l'onglet "RECAP" comme nom du fichier. Si l'utilisateur annule la fenêtre de sauvegarde, la feuille "RECAP" sera supprimée.
Attention, si vous avez déjà une feuille "RECAP" existante, assurez-vous que son contenu dans la cellule "I11" est correctement configuré avant d'exécuter le code.

Sub ExportAthenes()
    Dim wsMasque As Worksheet
    Dim wsMatrice As Worksheet
    Dim wsRecap As Worksheet
   
    ' Définir les références aux feuilles
    Set wsMasque = ThisWorkbook.Sheets("MASQUE")
    Set wsMatrice = ThisWorkbook.Sheets("MATRICE")
   
    ' Copier la feuille "MASQUE" pour créer "RECAP"
    wsMasque.Copy After:=wsMatrice
    Set wsRecap = ActiveSheet
    wsRecap.Name = "RECAP"
   
    ' Filtrer et copier les données
    With wsMatrice.Range("B10").CurrentRegion
        .AutoFilter Field:=8, Criteria1:="VILLE - Athènes"
        .SpecialCells(xlCellTypeVisible).Copy wsRecap.Range("B11")
        .AutoFilter
    End With
   
    ' Demander à l'utilisateur de choisir l'emplacement et le nom du nouveau fichier
    Dim newFileName As String
    newFileName = Application.GetSaveAsFilename(FileFilter:="Fichiers Excel (*.xlsx), *.xlsx")
   
    If newFileName <> "False" Then ' Si un nom de fichier valide est fourni
        ' Enregistrer le nouveau fichier
        wsRecap.Parent.SaveAs newFileName
        wsRecap.Parent.Close False ' Fermer le nouveau fichier
    Else
        wsRecap.Parent.Delete ' Supprimer la feuille "RECAP" si aucun fichier n'a été enregistré
    End If
End Sub

A+

 

[Jacky67]

Bonsoir à tous,
Bonsoir Jacky67,

Je me permets de revenir vers vous pour savoir si, via le classeur test créé par vos soins, il serait envisageable avec le même critère :

With Sheets("MATRICE").[a10].CurrentRegion
.AutoFilter Field:=8, Criteria1:="VILLE - Athènes"
.SpecialCells(xlCellTypeVisible).Copy [a11]
.AutoFilter
End With

au lieu de l'enregistrer dans l'onglet "VILLE" de l'exporter dans un nouveau classeur .xlsx (sans liens, sans menus déroulants, ni formules mais avec la même mise en page), nommé en fonction du critère (ici : VILLE - Athènes) et un emplacement d'enregistrement à sélectionner manuellement lors de chaque opération ?

Merci pour votre aide.

de_hanstrapp

RE..
Le hanstrapp est de nouveau derrière son PC , il va pouvoir répondre alors........
Donc, plus de feuille "Ville" et choix de l'emplacement d'enregistrement.
Voir la pj avec ce code

Sub ExportAA()
    Dim Fichier
    Application.ScreenUpdating = False
    Fichier = Application.GetSaveAsFilename("VILLE - Athènes", Filefilter:="Excel Files (*.xlsx), *.xlsx")
    If Fichier = False Then
        MsgBox "Fichier non enregisté.", vbInformation, "Information"
        Exit Sub
    End If
    With ThisWorkbook.Sheets("MATRICE").[a10].CurrentRegion
        .AutoFilter Field:=8, Criteria1:="VILLE - Athènes"
        .Copy
    End With
    Workbooks.Add
    With ActiveWorkbook.Sheets(1)
        .UsedRange.PasteSpecial Paste:=xlPasteColumnWidths
        .[a10].PasteSpecial Paste:=xlPasteFormats
        .[a10].PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        ThisWorkbook.Sheets("MATRICE").Rows("1:9").Copy .[a1]
        .Name = "VILLE - Athènes"
    End With
    Application.DisplayAlerts = False: ActiveWorkbook.SaveAs Filename:=Fichier: Application.DisplayAlerts = True
    ActiveWorkbook.Close
    ThisWorkbook.Sheets("MATRICE").[a10].AutoFilter
End Sub

 

[de_hanstrapp]

Bonsoir
Essaie ce code.
Ce code va demander à l'utilisateur de choisir l'emplacement et le nom du nouveau fichier Excel à enregistrer. Il va utiliser le contenu de la cellule "I11" de l'onglet "RECAP" comme nom du fichier. Si l'utilisateur annule la fenêtre de sauvegarde, la feuille "RECAP" sera supprimée.
Attention, si vous avez déjà une feuille "RECAP" existante, assurez-vous que son contenu dans la cellule "I11" est correctement configuré avant d'exécuter le code.

Sub ExportAthenes()
    Dim wsMasque As Worksheet
    Dim wsMatrice As Worksheet
    Dim wsRecap As Worksheet
  
    ' Définir les références aux feuilles
    Set wsMasque = ThisWorkbook.Sheets("MASQUE")
    Set wsMatrice = ThisWorkbook.Sheets("MATRICE")
  
    ' Copier la feuille "MASQUE" pour créer "RECAP"
    wsMasque.Copy After:=wsMatrice
    Set wsRecap = ActiveSheet
    wsRecap.Name = "RECAP"
  
    ' Filtrer et copier les données
    With wsMatrice.Range("B10").CurrentRegion
        .AutoFilter Field:=8, Criteria1:="VILLE - Athènes"
        .SpecialCells(xlCellTypeVisible).Copy wsRecap.Range("B11")
        .AutoFilter
    End With
  
    ' Demander à l'utilisateur de choisir l'emplacement et le nom du nouveau fichier
    Dim newFileName As String
    newFileName = Application.GetSaveAsFilename(FileFilter:="Fichiers Excel (*.xlsx), *.xlsx")
  
    If newFileName <> "False" Then ' Si un nom de fichier valide est fourni
        ' Enregistrer le nouveau fichier
        wsRecap.Parent.SaveAs newFileName
        wsRecap.Parent.Close False ' Fermer le nouveau fichier
    Else
        wsRecap.Parent.Delete ' Supprimer la feuille "RECAP" si aucun fichier n'a été enregistré
    End If
End Sub

A+

Bonjour chaelie15, à l’exécution de ta macro j'ai un bug sur la ligne : wsRecap.Parent.SaveAs newFileName (le nom d'enregistrement est vide).

 

[de_hanstrapp]

RE..
Le hanstrapp est de nouveau derrière son PC , il va pouvoir répondre alors........
Donc, plus de feuille "Ville" et choix de l'emplacement d'enregistrement.
Voir la pj avec ce code

Sub ExportAA()
    Dim Fichier
    Application.ScreenUpdating = False
    Fichier = Application.GetSaveAsFilename("VILLE - Athènes", Filefilter:="Excel Files (*.xlsx), *.xlsx")
    If Fichier = False Then
        MsgBox "Fichier non enregisté.", vbInformation, "Information"
        Exit Sub
    End If
    With ThisWorkbook.Sheets("MATRICE").[a10].CurrentRegion
        .AutoFilter Field:=8, Criteria1:="VILLE - Athènes"
        .Copy
    End With
    Workbooks.Add
    With ActiveWorkbook.Sheets(1)
        .UsedRange.PasteSpecial Paste:=xlPasteColumnWidths
        .[a10].PasteSpecial Paste:=xlPasteFormats
        .[a10].PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        ThisWorkbook.Sheets("MATRICE").Rows("1:9").Copy .[a1]
        .Name = "VILLE - Athènes"
    End With
    Application.DisplayAlerts = False: ActiveWorkbook.SaveAs Filename:=Fichier: Application.DisplayAlerts = True
    ActiveWorkbook.Close
    ThisWorkbook.Sheets("MATRICE").[a10].AutoFilter
End Sub

Bonjour Jacky67,

Merci pour la modification du fichier que tu avais créé.

Quelques retours / questions :

- Une fois la macro exécutée, quand j'enregistre le fichier j'ai le message suivant qui apparait : Cette image est trop grande et va être tronquée (il apparait deux fois). A l'ouverture du fichier "VILLE - Athènes" je remarque que la forme en bleu a été modifiée (j'imagine que les deux sont liés).

- Pour des raisons esthétiques, dans l'onglet "MATRICE" la hauteur de la ligne "10" est configurée à 60, dans l'export elle est de la même hauteur que les suivantes. Est-il possible d'y remédier ?

- Dans le même esprit, dans l'onglet "MATRICE", je souhaite ne pas voir apparaitre le quadrillage... est-il possible que dans l'export il ne s'affiche pas non plus ?

- Dernière question : vu qu'il y a plusieurs villes, est-il possible de pouvoir sélectionner via un userform ? ou menu déroulant ? la ville pour laquelle on souhaite faire le filtre et l'export ?

Merci milles fois pour ton aide.

de_hanstrapp

 

[Jacky67]

Bonjour Jacky67,

Merci pour la modification du fichier que tu avais créé.

Quelques retours / questions :

- Une fois la macro exécutée, quand j'enregistre le fichier j'ai le message suivant qui apparait : Cette image est trop grande et va être tronquée (il apparait deux fois). A l'ouverture du fichier "VILLE - Athènes" je remarque que la forme en bleu a été modifiée (j'imagine que les deux sont liés).

- Pour des raisons esthétiques, dans l'onglet "MATRICE" la hauteur de la ligne "10" est configurée à 60, dans l'export elle est de la même hauteur que les suivantes. Est-il possible d'y remédier ?

- Dans le même esprit, dans l'onglet "MATRICE", je souhaite ne pas voir apparaitre le quadrillage... est-il possible que dans l'export il ne s'affiche pas non plus ?

- Dernière question : vu qu'il y a plusieurs villes, est-il possible de pouvoir sélectionner via un userform ? ou menu déroulant ? la ville pour laquelle on souhaite faire le filtre et l'export ?

Merci milles fois pour ton aide.

de_hanstrapp

Re..
D'après le modèle en #8, il y a changement de colonne pour les villes.
Selon ce classeur, et sans structure réelle, une ultime version...

 

[de_hanstrapp]

Re..
D'après le modèle en #8, il y a changement de colonne pour les villes.
Selon ce classeur, et sans structure réelle, une ultime version...

Merci très sincèrement Jacky67 !
C'est top !
Mon unique question : pourquoi l'élippse est déformée à l'export. Jai essayé de changer des paramètres et j'ai également éssayé avec une image mais le résultat est le même. Un solution ?
de_hanstrapp

 

[Jacky67]

Merci très sincèrement Jacky67 !
C'est top !
Mon unique question : pourquoi l'élippse est déformée à l'export. Jai essayé de changer des paramètres et j'ai également éssayé avec une image mais le résultat est le même. Un solution ?
de_hanstrapp

Re.
Avant tout
Pour mes essais, j'avais placé cette ligne dans les codes
Application.EnableEvents = False
Il faut a tout prix la supprimer
Pour l'ellipse, je n'éprouve aucune difficulté elle n'est pas déformée chez moi.
Néanmoins vérifier dans ses propriétés et cocher
-Conserver les proportions
-Déplacer sans dimensionner avec les cellules
Sinon, je n'ai pas de solution dans ce cas.