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

Copier toutes les lignes correspondantes à un filtre

Créer une discussion
  • Initiateur de la discussion Initiateur de la discussion thyuki
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
T

thyuki

XLDnaute Nouveau
Bonjour à tous,

pour chaque nom présent dans la colonne P, je voudrais copier l'ensemble des lignes correspondante et les coller dans un nouveau fichier et l'enregistrer avec le nom et la date de la personne.
j'ai réussi à faire cette fonction que j'appelle pour chacun des noms de la liste.
Mon soucis vient de la sauvegarde. J'ai le message d'erreur suivant:
"Erreur d#exécution '1004': la méthode 'SaveAs' de l'objet '_Workbook' a échoué"

Code: 
Function BAIER()
    StrPath = "\\hld.net\dfs\groups\cbi\CBI30_Pub\Planung\CR-reports\VBA\BAIER\"             'final path
    StrName = "BAIER" & "_" & Format(Now(), "mm-dd-yyyy") & ".xls"                          'final name
    ActiveSheet.ListObjects("Tabelle_Reporting.accdb").Range.AutoFilter Field:=16 _
        , Criteria1:="BAIER"
    Range("Tabelle_Reporting.accdb").Select
    Range("P2").Activate
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=StrPath & StrName, CreateBackup:=True, ConflictResolution:=xlLocalSessionChanges
    Application.DisplayAlerts = True
    Workbooks(StrName).Close
    Workbooks("CR-Review-DB.xls").Activate
End Function

Ce code est issu d'un enregistrement de macro que j'ai fait et que j'ai modifié.

Je n'arrive pas à comprendre ce qui empêche la sauvegarde.

Pouvez-vous m'aider?

Merci
Thyuki
 
Dernière édition:
Trier par date Trier par votes
Re : Copier toutes les lignes correspondantes à un filtre

Bonjour à tester
a+
papou😱

Code: 
Function BAIER()
    StrPath = "\\hld.net\dfs\groups\cbi\CBI30_Pub\Planung\CR-reports\VBA\BAIER\"             'final path
    StrName = "BAIER" & "_" & Format(Now(), "mm-dd-yyyy") & ".xls"                          'final name
    ActiveSheet.ListObjects("Tabelle_Reporting.accdb").Range.AutoFilter Field:=16 _
        , Criteria1:="BAIER"
    Range("Tabelle_Reporting.accdb").Select
    Range("P2").Activate
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste    
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs (StrPath & StrName)
    Application.DisplayAlerts = True
    Workbooks(StrName).Close 1
    Workbooks("CR-Review-DB.xls").Activate
End Function
 
Vote positif 0 Vote négatif
Re : Copier toutes les lignes correspondantes à un filtre

Re Thyuki le forum
oui c'est cela ta procédure n'était pas bien écrite c'est tout
Mets les deux macros l'une en dessous de l'autre et regarde ce que j'ai retiré
a+
Papou😱
 
Vote positif 0 Vote négatif
Re : Copier toutes les lignes correspondantes à un filtre

Ok,

je vois d'où vient l'erreur.

Merci en tout cas.


Maintenant j'ai le soucis inverse.
Après avoir séparé les lignes dans différents fichiers, je dois rassembler les lignes d'un certains nombres d'excel dans un seul en mettant les données les unes à la suite des autres.

Voici mon code mais j'ai une erreur à la ligne où je colle mes lignes sélectionnées.
pouvez-vous m'aider?
Code: 
Sub multiselection()

    Dim rep As Long
    Dim Liste, StrPath, StrName, nomfich, Name As String
    Dim compteur As Byte
    Dim DernLigne, DernLigneA As Integer
    
    
    StrPath = "Q:\cbi\CBI30_Pub\Planung\CR-reports\"
    StrName = InputBox("Please choose the new Workbook's name")
    'Strnamecomplet = Strname & ".xlsx"
    Workbooks.Add
    Worksheets(1).SaveAs (StrPath & StrName)
    DernLigne = Workbooks(StrName).Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
    
    ' Affichage de la boîte de dialogue standard "Ouvrir" pour sélection de(s) fichier (s)
    ChDir StrPath
    nomfich = Application.GetOpenFilename(Title:="Choose the files to open", MultiSelect:=True)
    
    ' si aucun choix effectué, sortie du programme
    If TypeName(nomfich) = "Boolean" Then
    'MsgBox("Aucun fichier n'a été sélectionné. Fin de la procédure", vbCritical + vbOKOnly,"Sortie")
        Exit Sub
    End If
    
    Application.DisplayAlerts = False
    For compteur = 1 To UBound(nomfich)
        DernLigne = Workbooks(StrName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
        Workbooks.Open Filename:=nomfich(compteur)
        Name = Right(nomfich(compteur), Len(nomfich(compteur)) - 40)
        
        Workbooks(Name).Activate
        DernLigneA = Workbooks(Name).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
        Range("A2", (Cells(DernLigneA, 42))).Copy
        'Workbooks(Strname).Worksheets(1).Cells(DernLigneA, 1).Paste
        Workbooks(StrName).Worksheets(1).Range(Cells(DernLigneA, 1)).Paste
        Workbooks(Name).Close
        
    Next compteur
    Application.DisplayAlerts = True
    
End Sub
 
Vote positif 0 Vote négatif
Re : Copier toutes les lignes correspondantes à un filtre

Bonsoir le forum
c'est quoi ta plaisanterie là
If TypeName(nomfich) = "Boolean" Then
'MsgBox("Aucun fichier n'a été sélectionné. Fin de la procédure", vbCritical + vbOKOnly,"Sortie")

Si le type est Boolean c'est Egal à 0 ou a 1
de plus toutes tes variables ou presque sont déclarées en Variant!!!!! pas bien
si tu écris dim a,b$ cela signifie, que a sera variant, et b sera un string
a+
Papou😱
 
Vote positif 0 Vote négatif
Re : Copier toutes les lignes correspondantes à un filtre

Bonsoir à tous

Pour la syntaxe bizarroïde, plutôt que
Code: 
If TypeName(nomfich) = "Boolean" Then
écrire
Code: 
If nomfich = False Then

Bonne suite
 
Vote positif 0 Vote négatif
Re : Copier toutes les lignes correspondantes à un filtre

Bonjour à tous,

merci pour vos remarques, effectivement je ne sais plus où j'ai trouvé cette ligne...

J'ai vérifié tout mon code et supprimer ce qui ne me paraissait pas pertinent.
Mon erreur est toujours là, et je ne sais toujours pas pourquoi.

Voici le nouveau code, et encore merci de votre aide
Code: 
Sub multiselection()

    Dim rep As Long
    Dim StrPath As String, StrName As String, nomrep As String, Name As String
    Dim DernLigne As Integer, DernLigneA As Integer
    Dim FilesInPath As String
    Dim MyFiles() As String
    Dim Fnum As Long
    Dim mybook As Workbook
    Dim rnum As Long
    DernLigne = 2
    DernLigneA = 0
    
    StrPath = "Q:\cbi\CBI30_Pub\Planung\CR-reports\"
    StrName = InputBox("Please choose the new Workbook's name")
    Workbooks.Add
    Worksheets(1).Activate
    ActiveWorkbook.SaveAs (StrPath & StrName)
    DernLigne = Workbooks(StrName).Sheets(1).Range("A65536").End(xlUp).Row
    
    nomrep = "Q:\cbi\CBI30_Pub\Planung\CR-reports\VBA\" & Format(Now(), "yyyy-mm-dd") & "\"
    FilesInPath = Dir(nomrep & "*.xl*")
        
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop
    
    Application.DisplayAlerts = False
    For Fnum = LBound(MyFiles) To UBound(MyFiles)
        Set mybook = Workbooks.Open(nomrep & MyFiles(Fnum))
        Name = MyFiles(Fnum)
        mybook.Worksheets(1).Cells.AutoFilter
        mybook.Worksheets("Sheet1").Activate
        ActiveWindow.FreezePanes = False
        DernLigne = DernLigne + DernLigneA
        mybook.Activate
        DernLigneA = mybook.Worksheets(1).Range("A1").End(xlDown).Row
        mybook.Worksheets(1).Range("A1", (Cells(DernLigneA, 42))).Copy
        Workbooks(StrName).Worksheets(1).Range(DernLigne, 1).Activate
        Selection.PasteSpecial xlPasteColumnWidths
        ActiveSheet.Paste
        Selection.PasteSpecial xlPasteAllUsingSourceTheme
        mybook.Close
    Next Fnum
    
    Application.DisplayAlerts = True
    
End Sub
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…