Macro pour copier des valeurs à la suite d'un tableau

Bonjour,

J'ai un classeur excel comportant deux feuilles en pièce jointe. J'aimerais savoir s'il est possible de faire une macro permettant de mettre en avant toutes les nouvelles valeurs supérieures à -2500€ dans la colonne H de la feuille "rapport source" et de copier le numéro correspondant en colonne A pour le coller sur la feuille "suivi K12" à la suite du tableau en colonne B ?

Merci d'avance

Cdlt

Attention le fichier joint est bogué : Dans la feuille 1 (suivi K12) supprimer les lignes > à la ligne 20...

Nota : par nouvelles valeurs il faut comprendre celles dont la date colonne 3 est plus récente que la dernière de la feuille Suivi...

A+

Pour l'instant j'ai une macro qui fait à peu près le job avec quand même un problème notoire : je n'arrive pas à récupérer dans un array la plage filtrée : il y a 2 lignes filtrées mais l'Array ne charge qu'une ligne...

Est-ce possible de récupérer ces données avec .SpecialCells(xlVisible) ???

Nota : Je récupère les valeurs "en dur" pour éviter de propager de multiples rechercheV...

L'état actuel de ma réflexion :

Sub MajSuivK()
Dim TSuiv, NiD&, D&, i&, LR As ListRow, rng As Range
Dim TData, Arr, ArrS(18)
Set TSuiv = Range("TSK").ListObject
D = Application.Max(TSuiv.ListColumns(3).Range)
Set TData = Range("TSRC").ListObject
   TData.DataBodyRange.Sort key1:=Feuil2.Range("C1"), order1:=xlAscending, Header:=xlYes
   TData.Range.AutoFilter Field:=3, Criteria1:=">44358", Operator:=xlAnd
   TData.Range.AutoFilter Field:=8, Criteria1:="<-2500", Operator:=xlAnd
   Arr = TData.DataBodyRange.SpecialCells(xlVisible).Value
   For i = 1 To UBound(Arr)
      NiD = Application.Max(TSuiv.ListColumns(1).Range) + 1
      Set LR = TSuiv.ListRows.Add
      ArrS(0) = NiD
      ArrS(1) = Arr(i, 1)
      ArrS(2) = Arr(i, 3)
      ArrS(3) = Arr(i, 2)
      ArrS(4) = Arr(i, 6)
      ArrS(5) = Arr(i, 7)
      ArrS(6) = Arr(i, 4)
      ArrS(9) = Arr(i, 8)
      LR.Range.Value = ArrS
   Next
End Sub

A+

Bonjour,

A essayer

Sub MajSuivK()
    Dim TSuiv, NiD&, D&, i&, LR As ListRow, rng As Range
    Dim TData, Arr, ArrS(18)
    Dim plage As Range

    Set TSuiv = Range("TSK").ListObject
    D = Application.Max(TSuiv.ListColumns(3).Range)
    Set TData = Range("TSRC").ListObject
        TData.DataBodyRange.Sort key1:=Feuil2.Range("C1"), order1:=xlAscending, Header:=xlYes
        TData.Range.AutoFilter Field:=3, Criteria1:=">44358", Operator:=xlAnd
        TData.Range.AutoFilter Field:=8, Criteria1:="<-2500", Operator:=xlAnd

        For Each plage In TData.DataBodyRange.SpecialCells(xlVisible).Areas

            Arr = plage.Value
            For i = 1 To UBound(Arr)
               NiD = Application.Max(TSuiv.ListColumns(1).Range) + 1
               Set LR = TSuiv.ListRows.Add
               ArrS(0) = NiD
               ArrS(1) = Arr(i, 1)
               ArrS(2) = Arr(i, 3)
               ArrS(3) = Arr(i, 2)
               ArrS(4) = Arr(i, 6)
               ArrS(5) = Arr(i, 7)
               ArrS(6) = Arr(i, 4)
               ArrS(9) = Arr(i, 8)
               LR.Range.Value = ArrS
            Next i

       Next plage
End Sub

Bonsoir,

[EDIT] Thev : Sorry pas vu ta réponse mais très bien : Nous n'avions pas tout à fait le même fichier mais j'ai testé et je résultat semble impeccable : il me reste à éplucher... Merci.

Finalement je pense que le système de filtrage offre peu d’intérêt en parcourant tout le tableau ligne par ligne on obtient le même résultat sans perte de temps significative... (Compte tenu que le volume de donnée à rapatrier sera semble-t-il relativement modeste : Il s'agit d'annulations)

J'ai donc résolu le problème par une simple lecture des 2 Array et ajout des nouvelles lignes le cas échéant...

La macro finale :

Sub MajSuivK()
Dim ArrS, Arr(18), D&, i&, NID
Dim TData As ListObject, LR As ListRow
Application.ScreenUpdating = False
Set TData = Range("TSK").ListObject
D = Application.Max(TData.ListColumns(3).Range)
ArrS = [TSRC].Value
For i = LBound(ArrS) To UBound(ArrS)
   If ArrS(i, 3) > D And ArrS(i, 8) < -2500 Then
      NID = Application.Max(TData.ListColumns(1).Range) + 1
      Set LR = TData.ListRows.Add
      Arr(0) = NID
      Arr(1) = ArrS(i, 1)
      Arr(2) = ArrS(i, 3)
      Arr(3) = ArrS(i, 2)
      Arr(4) = ArrS(i, 6)
      Arr(5) = ArrS(i, 7)
      Arr(6) = ArrS(i, 4)
      Arr(9) = ArrS(i, 8)
      LR.Range.Value = Arr
   End If
Next
End Sub

A+

Pour revenir sur la solution de Thev qui me semble bien fonctionner et que je mets dans ma besace, il me semble que cette solution est particulièrement adaptée si les 2 feuilles comportent plusieurs dizaines (centaines) de milliers de lignes et si le nombre d'ajouts quotidiens est très nombreux. S'il ne s'agit que de récupérer quelques lignes à chaque fois ma solution est suffisante...

A+