copie de lignes vers un nouveau fichier suivant condition

[snowpaulo]

Bonjour !,

Voici mon petit souci, ma petite requête :

J’ai un fichier XL d’environ 15 000 lignes et 29 colonnes, une masse d’informations actualisées quotidiennement.

Je souhaiterai extraire les lignes pour lesquelles, dans la colonne F (où il n’y a que des codes à 5 lettres) les 2 premières lettres sont FR, puis DE, puis UK, etc.… j’en choisirai une quinzaine sur 150 codes existants. Ces lignes seront à recopier dans un nouveau fichier XL.

Must ultime : dans ce nouveau fichier XL que je souhaiterai appeler « mes codes », il faudrait que la 1ere ligne soit une copie identique du fichier initiale afin que les lignes extraites retrouvant leurs titres/leurs significations

J’espère être clair, c’est mon premier post sur un forum tout sujet confondu….

 

[job75]

Re : copie de lignes vers un nouveau fichier suivant condition

Bonsoir snowpaulo,

C'est votre 2ème post mais bienvenue encore sur XLD.

Je ne fais pas de code pour l'ouverture du fichier mes codes, je le suppose ouvert.

Mettez ce code où vous voulez dans le fichier source, en l'adaptant au besoin :

Sub FiltreCopie()
Dim tablo, cel As Range, i As Byte, lig As Integer
tablo = Array("FR", "DE", "UK") 'à compléter bien sûr
With Workbooks("mes codes.xls").Sheets("Feuil1") 'à adapter éventuellement
  .Cells.Clear 'efface tout
  Rows(1).Copy .Rows(1) 'copie la ligne de titre
  lig = 1
  For Each cel In Range("F2", Range("F65536").End(xlUp))
    For i = 0 To UBound(tablo)
     If cel Like tablo(i) & "*" Then 'respecte la casse, sinon => Ucase(cel) Like tablo(i)
       lig = lig + 1
       cel.EntireRow.Copy .Rows(lig)
       [COLOR="red"]GoTo 1[/COLOR]
      End If
    Next
[COLOR="Red"]1[/COLOR] Next
End With
End Sub

A+

 

[snowpaulo]

Re : copie de lignes vers un nouveau fichier suivant condition

Merci beaucoup job75, c'est exactement que je voulais faire, je suis bluffé. J'ai le sourire aux lèvres . Je vais mettre tout ça à ma sauce dès demain matin.

A bientôt !

 

[job75]

Re : copie de lignes vers un nouveau fichier suivant condition

Re,

Pour accélérer le code, j'ai édité le post précédent en ajoutant la ligne en rouge.

A+

 

[job75]

Re : copie de lignes vers un nouveau fichier suivant condition

Rebonsoir encore,

J'ai testé la macro précédente sur 15000 lignes : elle s'exécutait en 27 secondes...

Celle-ci s'exécute en 1 seconde (avec une copie en bloc à la fin) :

Sub FiltreCopie()
Dim tablo, cel As Range, i As Byte, cop As Range
tablo = Array("FR", "DE", "UK") 'à compléter bien sûr
With Workbooks("mes codes.xls").Sheets("Feuil1") 'à adapter éventuellement
  .Cells.Clear 'efface tout
  Rows(1).Copy .[A1] 'copie la ligne de titre
  For Each cel In Range("F2", Range("F65536").End(xlUp))
    For i = 0 To UBound(tablo)
     If cel.Text Like tablo(i) & "*" Then 'respecte la casse, sinon => Ucase(cel) Like tablo(i)
       Set cop = Union(cel.EntireRow, IIf(cop Is Nothing, cel.EntireRow, cop))
       GoTo 1
      End If
    Next
1 Next
cop.Copy .[A2]
End With
End Sub

A+