Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

D

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
 
Trier par date Trier par votes

Jacky67

XLDnaute Barbatruc
de_hanstrapp à dit:
Bonsoir le forum,
Est-il possible d'optimiser la durée du traitement ?

de_hanstrapp
Cliquez pour agrandir...
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
Vote positif 0 Vote négatif
D

de_hanstrapp

XLDnaute Occasionnel
Merci Jacky67 c'est parfait et bcp bcp plus rapide !
Bonne journée.
de_hanstrapp
 
Vote positif 0 Vote négatif
D

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:
Vote positif 0 Vote négatif

Jacky67

XLDnaute Barbatruc
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:
Vote positif 0 Vote négatif
D

de_hanstrapp

XLDnaute Occasionnel
Jacky67 à dit:
Re...
D'où l'intérêt de joindre un classeur avec la structure définitive...
Avec le classeur test
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif

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+
 
Vote positif 0 Vote négatif
D

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
Vote positif 0 Vote négatif

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+
 
Vote positif 0 Vote négatif

Jacky67

XLDnaute Barbatruc
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:
Vote positif 0 Vote négatif
D

de_hanstrapp

XLDnaute Occasionnel
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).
 
Vote positif 0 Vote négatif
D

de_hanstrapp

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif

Jacky67

XLDnaute Barbatruc
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: 4
Vote positif 0 Vote négatif
D

de_hanstrapp

XLDnaute Occasionnel
Jacky67 à dit:
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...
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif

Jacky67

XLDnaute Barbatruc
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:
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Question
Microsoft 365 [VBA] Enchaîner déplacer lignes + supprimer les lignes vides.
Réponses
3
Affichages
794
ARMAEL
A
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
  • Question
XL 2019 Fusionner jusqu'à dernière colonne contenant
Réponses
8
Affichages
642
TooFatBoy
  • Question
XL 2016 Protéger Plage avec condition
2
Réponses
16
Affichages
906
Amigo
  • Question
XL 2021 Optimisation code pour affichage ligne et colonne
Réponses
14
Affichages
678
patricktoulon
N
  • Résolu(e)
Microsoft 365 Mettre la 4ème colonne d'une ListBox au format [h]:mm
3 4 5
Réponses
68
Affichages
1 K
NONO14
N
M
  • Question
Microsoft 365 Modifier code et format textbox
2 3
Réponses
35
Affichages
2 K
Marvin57
M
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
528
AtTheOne
  • Question
XL 2016 Ajuster les lignes au Contenu
Réponses
4
Affichages
466
KTM
S
  • Résolu(e)
Microsoft 365 Boucle pour afficher et masquer des lignes
Réponses
12
Affichages
519
shf
S
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…