Exist-il une macro rapide pour copier/coller en fonction du resultat d'une cellule?

[Delux]

Bonjour a tous,

Veuillez m'excuser pour les accents je travaille sur QWERTY.

Alors voila, apres avoir beaucoup appris sur ce forum (merci a vous tous), je reviens vers vous avec une question:

Exist-il une macro rapide pour copier/coller, d'une feuille a une autre, en fonction du resultat d'une cellule (toutes contenues dans la meme colonne)?

Je vous ai mis un fichier exemple raccourci et reduit a mort (le vrai fichier va jusqu'a la ligne 17500). Celui-ci n'est pas tres lent etant donne qu'il est allege ^^.

Voici la macro que j'utilise actuellement, mais celle-ci prend trop de temps a s'executer:

Sub Import()

Dim mySource As Range
Dim myCible As Range
Dim Cel As Range
Dim Lg As Integer

Set mySource = Sheet2.Range("BK8:BK65489")
Set myCible = Sheet1.Range("B13:U65489")

Application.ScreenUpdating = False

myCible.ClearContents

Lg = 13

For Each Cel In mySource
    If Cel.Value > 14 And Cel.Value <> "" Then
        Sheet1.Range("B" & Lg).Value = Sheet2.Range("AS" & Cel.Row).Value 'Doc Number
        Sheet1.Range("C" & Lg).Value = Sheet2.Range("AT" & Cel.Row).Value 'Revision
        Sheet1.Range("D" & Lg).Value = Sheet2.Range("BI" & Cel.Row).Value 'Dated
        Sheet1.Range("E" & Lg).Value = Sheet2.Range("AV" & Cel.Row).Value 'Title
        Sheet1.Range("L" & Lg).Value = Sheet2.Range("AW" & Cel.Row).Value 'Client Ref
        Sheet1.Range("M" & Lg).Value = Sheet2.Range("AX" & Cel.Row).Value 'Planned Date
        Sheet1.Range("N" & Lg).Value = Sheet2.Range("AY" & Cel.Row).Value 'Planned Rev
        Sheet1.Range("O" & Lg).Value = Sheet2.Range("AZ" & Cel.Row).Value 'Sent Date
        Sheet1.Range("P" & Lg).Value = Sheet2.Range("BA" & Cel.Row).Value 'Status
        Sheet1.Range("Q" & Lg).Value = Sheet2.Range("BB" & Cel.Row).Value '3rd Party Status
        Sheet1.Range("R" & Lg).Value = Sheet2.Range("BC" & Cel.Row).Value 'Comments date
        Sheet1.Range("S" & Lg).Value = Sheet2.Range("BD" & Cel.Row).Value 'Comments date received
        Sheet1.Range("T" & Lg).Value = Sheet2.Range("BE" & Cel.Row).Value 'CRS Sent date
        Sheet1.Range("U" & Lg).Value = Sheet2.Range("BF" & Cel.Row).Value 'CRS Closed Date
        Lg = Lg + 1
        
    End If
Next Cel
End Sub

Comme vous pouvez le constater, je n'extrais que certaines cellules de certaines colonnes pour les copier sur un autre tableau dans une nouvelle page.

Cela peut prendre jusqu'a 2 ou 3 minutes, car il faut traiter pas loin de 750 000 000 cellules.

si quelau'un grace a mon petit exemple aurait une solution, je serais ravis d'apprendre

En vous remerciant par avance,

Cordialement,

Delux

 

[Lolote83]

Re : Exist-il une macro rapide pour copier/coller en fonction du resultat d'une cellu

Salut Delux,
En passant par un filtre élaboré peut être.
Par contre dans ton fichier joint, la macro indique :

For Each Cel In mySource
    If Cel.Value = 1 Then
        Sheet1.Range("B" & Lg).Value = Sheet2.Range("AS" & Cel.Row).Value 'Doc Number
        Sheet1.Range("C" & Lg).Value = Sheet2.Range("AT" & Cel.Row).Value 'Revision

et dans la code ci-dessus tu indiques :

For Each Cel In mySource
    If Cel.Value > 14 And Cel.Value <> "" Then
        Sheet1.Range("B" & Lg).Value = Sheet2.Range("AS" & Cel.Row).Value 'Doc Number
        Sheet1.Range("C" & Lg).Value = Sheet2.Range("AT" & Cel.Row).Value 'Revision

Quel est donc le critère Cellule=1 ou cellule>14 et non vide.
Dans l'exemple donné, j'ai mis comme critère>14 (voir à partir de la colonne BO)
Au plaisir de te lire pour plus d'explications.
@+ Lolote83

 

[Delux]

Re : Exist-il une macro rapide pour copier/coller en fonction du resultat d'une cellu

Hello Lolote83,

Desole je n'ai pas fait attention.

En fait le critere est bien 1.

En fait j'ai plusieures macros et une qui cherche avec le deuxieme critere (>14).

Mais si j'arrive avec le critere 1 ca me suffit

Merci je vais y jeter un coup d'oeil
Ps: SI ce n'est pas trop demande, pourriez vous m'annoter votre macro pour que j'essaye de la comprendre

Cordialement,

Delux

 

[Lolote83]

Re : Exist-il une macro rapide pour copier/coller en fonction du resultat d'une cellu

Re salut
Au cas ou, tiens moi au jus !!!!
@+ Lolote83

 

[Delux]

Re : Exist-il une macro rapide pour copier/coller en fonction du resultat d'une cellu

Bonjour,

Merci pour ta solution, mais je ne la trouve pas tres pratique car cela rajoute des infos sur une feuille .
N'existe t-il pas d'autres methodes que celle du filtre elabore?

Merci d'avance

Cordialement,

Delux

 

[Lolote83]

Re : Exist-il une macro rapide pour copier/coller en fonction du resultat d'une cellu

Salut Delux,
En quoi cela rajoute des infos sur une feuille ?
Si tu veux, tu peux filtrer directement sur ta feuille de destination.
La méthode est très rapide, tu mets le critère que tu souhaite et tu obtiens rapidement un résultat.
Sinon, une macro comme la tienne est très correcte.
@+ Lolote83

 

[Delux]

Re : Exist-il une macro rapide pour copier/coller en fonction du resultat d'une cellu

Re bonjour,

Lolote83,
Je ne voulais pas t'offencer. En fait je ne maitrise pas ta solution et j'avoue ne pas savoir comment l'adapter comme tu viens de le dire.
En tout cas elle est tres bien aussi


Si non j'ai reussi a trouver une technique mais il y un petit soucis : elle me copie/colle les lignes vides :

Sub copyaste()

Dim Lg As Long
Dim Z As Variant 'Variant definit toute sorte de donnees
Dim Te() As Variant, Ts() As Variant

Application.ScreenUpdating = False

Sheet2.Select

Te = Sheet2.Range("AT8:BH" & [BH65489].End(xlUp).Row).Value ' Récupère toute les donnees du range A1:A... d'un coup.
ReDim Ts(1 To UBound(Te), 1 To 21) 'Redim permet de redimensionner le tableau de sortie (ici 1 ligne au nombre de ligne du range Te, et sur 21 colonne).
For Lg = 8 To UBound(Te): Z = Te(Lg, 15) ' Pour Lg = 1 au nombre de lignes: Ça vaut le coup d'écrire Z partout au lieu de Te(Lg, 15).
   If Z = 1 Then
         Ts(Lg, 1) = Te(Lg, 1)
         Ts(Lg, 2) = Te(Lg, 2)
         Ts(Lg, 3) = Te(Lg, 3)
         Ts(Lg, 4) = Te(Lg, 4)
         Ts(Lg, 11) = Te(Lg, 5)
         Ts(Lg, 12) = Te(Lg, 6)
         Ts(Lg, 13) = Te(Lg, 7)
         Ts(Lg, 14) = Te(Lg, 8)
         Ts(Lg, 15) = Te(Lg, 9)
         Ts(Lg, 16) = Te(Lg, 10)
         Ts(Lg, 17) = Te(Lg, 11)
         Ts(Lg, 18) = Te(Lg, 12)
         Ts(Lg, 19) = Te(Lg, 13)
         Ts(Lg, 20) = Te(Lg, 14)
      End If
   Next Lg
Sheet1.[B13:U65489].ClearContents
Sheet1.[B13:U13].Resize(UBound(Ts)).Value = Ts 'Décharge tout d'un coup
Sheet1.Select
End Sub

Je ne peux pas attacher le fichier exemple parce qu'avec cette macro le fichier arrive a 3.8M

Maintenant il faudrait que je puisse dire de ne copier que les lignes dont la cellule en colonne BH est = 1.

Si vous avez une solution?

Merci d'avance

Cordialement,

Delux

 

[Lolote83]

Re : Exist-il une macro rapide pour copier/coller en fonction du resultat d'une cellu

Re salut,
Je regarde dès que j'ai un peut de temps à moi et te tiens au courant.
@+ Lolote83

 

[laetitia90]

Re : Exist-il une macro rapide pour copier/coller en fonction du resultat d'une cellu

bonjour tous
as tu essayé un filtre???
autrement par "tablo" code brut pas le temps d'optimiser

Sub es()
 Dim t(), t1(), x As Long, i As Long, y As byte
 t = Sheet2.Range("as8:bl" & Sheet2.Cells(Rows.Count, 45).End(xlUp).Row).Value
 ReDim t1(1 To UBound(t), 1 To 20)
 For i = 1 To UBound(t)
 If t(i, 16) = 1 Then 'condition
 x = x + 1
 t1(x, 1) = t(i, 1): t1(x, 2) = t(i, 2)
 t1(x, 3) = t(i, 17): t1(x, 4) = t(i, 4)
 For y = 11 To 20: t1(x, y) = t(i, y - 6): Next y
 End If
 Next i
 Sheet1.[A13:U18000].ClearContents
 Sheet1.[b13].Resize(x, 20) = t1
 Erase t, t1
End Sub

ps oublie la suppression

 

[Delux]

Re : Exist-il une macro rapide pour copier/coller en fonction du resultat d'une cellu

Bonjour Laetitia90,

Desole de revenir aussi tardivement.

Merci pour ce code, je le testerai des que j'ai un peu de temps a moi

Cordialement,

Delux