Copier toutes les lignes correspondantes à un filtre

[thyuki]

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é"

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

 

[Paritec]

Re : Copier toutes les lignes correspondantes à un filtre

Bonjour à tester
a+
papou😱

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

 

[thyuki]

Re : Copier toutes les lignes correspondantes à un filtre

Cela fonctionne très bien, merci

Donc il s'agissait juste d'une erreur de syntaxe...

Merci encore

 

[Paritec]

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😱

 

[thyuki]

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?

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

 

[Paritec]

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😱

 

[Paf]

Re : Copier toutes les lignes correspondantes à un filtre

Bonsoir à tous

Pour la syntaxe bizarroïde, plutôt que

If TypeName(nomfich) = "Boolean" Then

écrire

If nomfich = False Then

Bonne suite

 

[thyuki]

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

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