Tri selectif d'un fichier excel en VBA

Version imprimable

bonjour, je suis débutant en VBA mais j'ai quelques connaissances en C, html et php
je voudrai créer une macro qui synchroniserai plusieurs fichiers excel à partir d'un fichier excel selon deux critères:

si la colonne D = "presta1" et la colonne E="erreur" de la ligne X
copie de la ligne X a la suite sur fichier "presta1.xls"
sinon
si la colonne D = "presta2" et la colonne E="erreur" de la ligne X
copie de la ligne X a la suite sur fichier "presta2.xls"
...ainsi de suite....

puis tous ça imbriqué dans une matrice de balayage pour balayer tous le fichier a trier

alors voici mon code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
 
 
Sub tri()
 
Dim l As Integer
Dim i As Integer
Dim WBSource As Workbook, WBDest As Workbook
Dim DerniereLigne As Integer
DerniereLigne = Range("D50").CurrentRegion.End(xlDown).Row
Set WBSource = Workbooks("SUIVI")
Set WBDest = Workbooks("presta1")
Set WBDest1 = Workbooks("presta2")
 
'sauvegarde une copie avec la date de l'execution
ActiveWorkbook.SaveAs Filename:=suivi_
"chemin\suivi" & Date & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
 
For l = 1 To DerniereLigne
 'balayage de toute ligne de 1 à 50
 
If (ActiveSheet.Cells(l, D) = "presta1") And (ActiveSheet.Cells(l, E) = "erreur") Then
'test si la cellule lD = presta1 et si la cellule lE = erreur
 
'alors faire ceci
 i = WBDest.Worksheets(1).Range("A65536").End(xlUp).Row + 1
'cherche une ligne vide dans WBdest
 
'copie la ligne l sur fichier destinataire
WBSource.Worksheets(1).Rows(l).Copy _
    Destination:=WBDest.Worksheets(1).Cells(i, 1)
 
'suprime la ligne de la source
WBSource.Worksheets(1).Rows(l).Delete
end if
If (ActiveSheet.Cells(l, D) = "presta2") And (ActiveSheet.Cells(l, E) = "erreur") Then
'test si la cellule lD = presta2 et si la cellule lE = erreur
 
'alors faire ceci
 i = WBDest1.Worksheets(1).Range("A65536").End(xlUp).Row + 1
'cherche une ligne vide dans WBdest1
 
'copie la ligne l sur fichier destinataire
WBSource.Worksheets(1).Rows(l).Copy _
    Destination:=WBDest1.Worksheets(1).Cells(i, 1)
 
'suprime la ligne de la source
WBSource.Worksheets(1).Rows(l).Delete
 end if
Next l
 
End Sub

mais ceci ne fonctionne pas, pouvez vous m'aidez?

Il est judicieux de faire un filtre automatique et de transférer le résultat en bloque que de balayer toutes les lignes.

Je suppose que le fichier contenant la macro et les fichiers presta1.xls et presta2.xls se trouvent dans le même répertoire

Les lignes correspondant aux critères presta1 ou presta 2 en D et erreur en E seront transférés dans le fichier adéquat et supprimés du fichier contenant la macro. Ce dernier sera enregistré sous forme suivi_aaaammjj.xlsm

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
Option Explicit
 
Sub TRANSFERT()
Dim Chemin As String, Presta As String, Suivi As String
Dim Ws As Worksheet, Wsd As Worksheet
Dim LastLig As Long, NewLig As Long
Dim Wbk As Workbook
Dim k As Byte
Dim Tb
 
Application.ScreenUpdating = False
Chemin = ThisWorkbook.Path & "\"
Tb = Array("presta1", "presta2")
 
Set Ws = ThisWorkbook.Worksheets(1)
For k = LBound(Tb) To UBound(Tb)
    Presta = Chemin & Tb(k) & ".xls"
    If Dir(Presta) <> "" Then
        With Ws
            .AutoFilterMode = False
            LastLig = .Cells(.Rows.Count, "D").End(xlUp).Row
            .Range("D1:E" & LastLig).AutoFilter Field:=1, Criteria1:=Tb(k)
            .Range("D1:E" & LastLig).AutoFilter Field:=2, Criteria1:="erreur"
 
            If .Range("D1:D" & LastLig).SpecialCells(xlCellTypeVisible).Count > 1 Then
                Set Wbk = Workbooks.Open(Presta)
                Set Wsd = Wbk.Worksheets(1)
                NewLig = Wsd.Cells(Wsd.Rows.Count, 1).End(xlUp).Row + 1
                With .Rows("2:" & LastLig).SpecialCells(xlCellTypeVisible)
                    .Copy Wsd.Cells(NewLig, 1)
                    .Delete
                End With
                Set Wsd = Nothing
                Wbk.Close True
            End If
 
            .AutoFilterMode = False
        End With
    End If
Next k
Set Ws = Nothing
 
Suivi = Chemin & "Suivi_" & Format(Date, "yyyymmdd")
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Suivi, xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
MsgBox "Traitement terminé"
End Sub

Edit: les fichiers presta1.xls et presta2.xls doivent être fermés

07/06/2014, 16h29
thejrem

1 pièce(s) jointe(s)

merci pour cette rapidité,
alors pour le moment le suivi est dans le même répertoire mais à terme non, pour bien séparer l'extract donc j'aurai trois répertoire échantillonnage , un suivi et un avec tous les presta
mais déjà que sa fonctionne sur le même répertoire après c'est juste le chemin d’accès qui change.
ton code termine sans erreur avec le message "Traitement terminé"
j'ai bien une copie identique avec la date du jour
mais le fichier presta 1 et presta 2 sont vides ils ne se remplissent pas.

en gros le but est de remplir les fichiers presta1,presta2,....(il y en a 20) avec les lignes en erreur de chaque presta du fichier suivi.

échantillonnage semaine regroupant 20 presta.
en fin de semaine on renvoi les lignes en erreur a chaque presta.
et au lieu de trier presta par presta copier collé ...
je veux automatiser tous ça.

donc voici mon logigramme
Pièce jointe 148047
07/06/2014, 16h38
mercatog

Si tes fichiers sont vide, c'est à dire quand on applique le filtre automatique sur D (critère presta1) et sur E (critère erreur) ça ne donné pas de lignes répondant aux 2 critères

Exécute le code pas à pas à l'aide de F8 et regarde ce qu'il faut adapter.

PS. Tu ne t'attends quand même pas à une solution fonctionnelle à 100% sans adaptation à tes fichiers
07/06/2014, 17h35
thejrem

non j’attends pas quelques chose de tous fais, j'ai mis le logigramme pour mieux comprendre le projet.

et j'ai un peu de mal a comprendre ton code.
mais le premier if si presta différent de ""
retourne toujours faux
donc il ne fais pas de comparaison des cellules
07/06/2014, 20h17
mercatog

Tu sais faire manuellement un filtre automatique sur une feuille excel?
Si oui, le code fait de même

oui j'ai compris c'est pour permettre le déplacement en bloc des données
je filtre par rapport à un presta et erreur et je copie toutes les lignes pleine sur le fichier presta

mon fichier suivi a déjà des filtres.
j'ai trouver ce code permettant de récupérer des données filtrées
mais il ne fonctionne pas et j'ai du mal à l'adapter
ou dois-je mettre les critères du filtre?
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 sub RecupereDataAutofiltre() Dim Destination As Range 'Définis ta plage où sera copiée les données. 'si même feuille oublis "Sheets" seulement Range(??) Set Destination = Sheets(3).Range("A1") Dim MaPlage As Range 'représente les données filtrées et les titres. Set MaPlage = Sheets("NomdeTaFeuille").AutoFilter.Range 'représente seulement les données Set MaPlage = MaPlage.Offset(1, 0).Resize(MaPlage.Rows.Count - 1, MaPlage.Rows.Count) MaPlage.Copy Destination end sub

11/06/2014, 01h51
mercatog

cf #2