Recherche de lignes puis copie à la suite d'autres recherches....dans autre feuille

[nobru26]

Bonjour,

J'ai un soucis pour une recherche/copie selon 2 critères, j'ai bien réussi via macro a rechercher et coller dans une autre feuille mais là j'ai plusieurs recherches en même temps dont le longueur du résultat n'est pas le même.

Explications:
je recherche dans la feuille ZONE1 selon critère "numéro semaine" et cellules non vides dans "description", là ou les deux critères sont réunis je dois copier les lignes et coller (seulement les valeurs) dans la feuille RECAP à partir de la ligne 7, et copier le sous total en bas de la feuille ZONE1 vers la fin des lignes du résultat de la recherche.... je m'embrouille dans mes explications!!!
et faire de même pour la semaine N+1
ensuite faire la même chose pour la ZONE2. etc... ZONE3...4....5 par la suite.

Problèmes; les recherches ne remontent pas toutes le même nombre de lignes, voir même rien suivant les saisies, et pour détecter les lignes vides dans la feuille RECAP je sèche..... De plus avant il faut vider la feuille RECAP mais ça ça devrait le faire, enfin garder les entêtes et la mise en forme, seulement pour vider il faut savoir à quel endroit vider....

Un petit exemple de fichier avec l'ébauche de ce que je vise......

Regarde la pièce jointe test nobru26.zip

Merci pour votre aide

 

[Cousinhub]

Re : Recherche de lignes puis copie à la suite d'autres recherches....dans autre feui

Bonsoir,

Regarde le fichier joint, tu changes le numéro de semaine dans la cellule A2 de l'onglet Report, et la mise à jour s'effectue.

Le code (pour ceux qui veulent voir le code, sans forcément télécharger le fichier) :

De l'évènement de feuille :

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Address = "$A$2" Then
    If IsNumeric(Target) And Target >= 1 And Target <= 52 Then
        Call Extract
    End If
End If
End Sub

Et dans le module 1 :

Sub Extract()
Dim Onglets, Ongl
Dim FRp As Worksheet
Dim Plg As Range, Cel As Range
Dim DerligR As Long, DerLigR2 As Long
Dim I As Byte
Dim Flag As Boolean
Application.ScreenUpdating = False
Onglets = Array("ZONE1", "ZONE2")
Set FRp = Sheets("Report")
Set Cel = FRp.Range("A2")
With FRp
    DerligR = .Cells(Rows.Count, "A").End(xlUp).Row
    If DerligR > 6 Then .Range("A7:J" & Rows.Count).Clear
End With
For Each Ongl In Onglets
    With Sheets(Ongl)
        Set Plg = .Range("A4:J" & .Cells(Rows.Count, "A").End(xlUp).Row)
        FRp.Range("B1") = Cel.Offset(-1): FRp.Range("B2") = Cel
        FRp.Range("C2").FormulaR1C1 = "=" & Ongl & "!R[3]C7<>"""""
        If Ongl = "ZONE2" And Not Flag Then
            DerligR = FRp.Cells(Rows.Count, "A").End(xlUp).Row + 4
            FRp.Rows("4:6").Copy FRp.Cells(DerligR, 1)
            FRp.Cells(DerligR, 1) = Ongl
            Flag = True
        End If
        For I = 0 To 1
            DerligR = FRp.Cells(Rows.Count, "A").End(xlUp).Row + 1
            If I = 1 Then
                If IsNumeric(FRp.Cells(DerligR - 1, "D")) Then DerligR = DerligR + 2
            End If
            Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=FRp.Range("B1:C2"), _
                CopyToRange:=FRp.Cells(DerligR, 1), Unique:=False
            FRp.Rows(DerligR).Delete
            DerLigR2 = FRp.Cells(Rows.Count, "A").End(xlUp).Row + 1
            If DerLigR2 > DerligR Then
                FRp.Cells(DerLigR2, "D") = Application.Sum(FRp.Cells(DerligR, "D").Resize(DerLigR2 - DerligR))
                FRp.Cells(DerLigR2, "E") = Application.Sum(FRp.Cells(DerligR, "E").Resize(DerLigR2 - DerligR))
                If Application.CountIf(FRp.Cells(DerLigR2, "D").Resize(1, 2), 0) = 0 Then
                    FRp.Cells(DerLigR2, "F") = Cells(DerLigR2, "E") / Cells(DerLigR2, "D")
                    FRp.Cells(DerLigR2, "F").NumberFormat = "0.00%"
                End If
            End If
            FRp.Range("B2") = FRp.Range("B2") + 1
        Next I
    End With
Next Ongl
FRp.Range("B1:C2").Clear
End Sub

Bon courage

 

[nobru26]

Re : Recherche de lignes puis copie à la suite d'autres recherches....dans autre feui

Bonsoir,

Je suis admiratif!!! et c'est très sérieux!
Un grand merci, j'arrive pas a comprendre comment vous pouvez faire ça aussi rapidement! je pensais un problème insurmontable et j'ai l'impression que pour vous c'est inné!
On dira chacun son métier.... LOL

 

[nobru26]

Re : Recherche de lignes puis copie à la suite d'autres recherches....dans autre feui

Je vais essayer d'adapter un poil le code, ça me fera "travailler" pour encadrer les totaux et mettre en gras, ce sera une prouesse pour moi!
LOL

J'ai l'impression d'être nul!

 

[nobru26]

Re : Recherche de lignes puis copie à la suite d'autres recherches....dans autre feui

Bonsoir,

Mes petites modification fonctionnent.

Par contre je n'arrive pas à effectuer la recherche dans plus de 2 feuilles, j'ai ajouté un onglet ZONE3 et ZONE4 et le code plante a:

Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=FRp.Range("B1:C2"), _
CopyToRange:=FRp.Cells(DerligR, 1), Unique:=False

J'ai bien sur ajoute ZONE3 et ZONE4 aux arrays et ZONE4 a la boucle FOR

Merci pour votre aide!

 

[Cousinhub]

Re : Recherche de lignes puis copie à la suite d'autres recherches....dans autre feui

Re-,

A tout hasard, sans filet, essaie en modifiant ces lignes...

For Each Ongl In Onglets
    [COLOR=#ff0000][B]Flag = False[/B][/COLOR]
    With Sheets(Ongl)
        Set Plg = .Range("A4:J" & .Cells(Rows.Count, "A").End(xlUp).Row)
        FRp.Range("B1") = Cel.Offset(-1): FRp.Range("B2") = Cel
        FRp.Range("C2").FormulaR1C1 = "=" & Ongl & "!R[3]C7<>"""""
        If Ongl [COLOR=#ff0000][B]<>[/B][/COLOR] "ZONE1" And Not Flag Then

Les modifs en gras et rouge...

Mais vraiment à tout hasard

PS : Je suppose que les onglets Zone3 et Zone4 ont exactement la même structure que les deux premiers (Même cellule de début, mêmes titres...)

Bon courage

Edit : Bon les modifications de Police ne sont pas passées, tu dois modifier ce qui est entre [COLOR....] (2 modifications)

 

[nobru26]

Re : Recherche de lignes puis copie à la suite d'autres recherches....dans autre feui

Salut!

Pour le modifs gras et couleur c'est pas trop important, merci.

Les autres feuilles ont la même structure, idem des autres ZONE1 et ZONE2.
Par contre ça fonctionne si je met dans les array ZONE1 et ZONE3 par exemple, mais des qu'il a plus de 2 sheets ça bloque.

Des idées?
Merci

 

[Cousinhub]

Re : Recherche de lignes puis copie à la suite d'autres recherches....dans autre feui

Bonjour,

Avec les modifs essayées, chez moi, pas de soucis, avec 4 zones...

La partie de code qui est donc modifiée :

    With Sheets(Ongl)
        Flag = False
        Set Plg = .Range("A4:J" & .Cells(Rows.Count, "A").End(xlUp).Row)
        FRp.Range("B1") = Cel.Offset(-1): FRp.Range("B2") = Cel
        FRp.Range("C2").FormulaR1C1 = "=" & Ongl & "!R[3]C7<>"""""
        If Ongl <> "ZONE1" And Not Flag Then
            DerligR = FRp.Cells(Rows.Count, "A").End(xlUp).Row + 4
            FRp.Rows("4:6").Copy FRp.Cells(DerligR, 1)
            FRp.Cells(DerligR, 1) = Ongl
            Flag = True
        End If

PS, j'avais pas fait gaffe, mais tu as un nombre impressionnant de formules dans tes onglets "ZONE.."

Ajoute cette ligne en tout début de code (ça ne va pas résoudre ton souci, mais on va gagner en temps de traitement...) :

Dim Calc As Long
With Application
    .ScreenUpdating = False
    Calc = .Calculation
    .Calculation = xlCalculationManual
End With
.....

Et en toute fin de code :

....
.....
Application.Calculation = Calc
End Sub

tu peux me dire quelle semaine "merdoie" chez toi?

 

[nobru26]

Re : Recherche de lignes puis copie à la suite d'autres recherches....dans autre feui

Salut!

Ta modif fonctionne a merveille, c'était juste le = a remplacer par le <> ?
Sinon il n'y a pas de semaine particulaire qui merdois, après mes 1ers essais tout roule!

Merci bp