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

de_hanstrapp

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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.......
Code:
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
 

Pièces jointes

  • ExportAA.xlsm
    31.4 KB · Affichages: 2

de_hanstrapp

XLDnaute Occasionnel
Bonjour,
Une proposition avec un filtre, et une ligne de titre
Mais sans classeur test.......
Code:
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

XLDnaute Occasionnel
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
 

Pièces jointes

  • ExportAA - Copie.xlsm
    27 KB · Affichages: 7
Dernière édition:

Jacky67

XLDnaute Barbatruc
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
 

Pièces jointes

  • ExportAA V2.xlsm
    33.9 KB · Affichages: 10
Dernière édition:

de_hanstrapp

XLDnaute Occasionnel
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

XLDnaute Accro
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 :
VB:
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

XLDnaute Occasionnel
Bonsoir chaelie2015, le forum,

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

VB:
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
 

Pièces jointes

  • ExportAA V2(1).xlsm
    34.9 KB · Affichages: 1

chaelie2015

XLDnaute Accro
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.
VB:
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

XLDnaute Barbatruc
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
VB:
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
 

Pièces jointes

  • ExportAA V2 Bis.xlsm
    33.1 KB · Affichages: 2
Dernière édition:

de_hanstrapp

XLDnaute Occasionnel
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.
VB:
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

XLDnaute Occasionnel
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
VB:
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

XLDnaute Barbatruc
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...
 

Pièces jointes

  • ExportAA V3.xlsm
    39.2 KB · Affichages: 3

de_hanstrapp

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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.
 
Dernière édition:

Discussions similaires

Réponses
4
Affichages
279
Réponses
12
Affichages
327

Statistiques des forums

Discussions
313 285
Messages
2 096 819
Membres
106 755
dernier inscrit
riviere gabriel