VBA : Extraction de ligne si condition

[Jean Peter Pek]

Bonjour à tous !

Je débute sur VBA et je souhaiterai extraire des données d'un fichier excel pour les mettre dans un autre fichier.
Je vous explique plus précisément mon objectif (ci-joint 2 fichiers) :

1 - Dans le fichier "extraction des données" je peux sélectionner le fichier dans lequel je souhaite extraire mes données.
2- Par la suite je souhaite que lorsque j'appuie sur le bouton "Extract" (Toujours dans le même fichier) le fichier aille piocher dans le fichier précédemment sélectionné les lignes présentes dans le fichier "Les données", onglet "Informations" et qu'il les copies dans mon autre fichier "Extraction des données" dans un nouvel onglet "Informations"
3- Par la suite, je souhaite supprimer les lignes ayant aucune information dans les colonne E & F (Valeur 8 et 9, les colonnes de couleur verte dans le fichier "Les données")

En espérant que quelqu'un puisse m'aider, merci à tous par avance.

Cordialement,

 

[Jean Peter Pek]

Personne pour aider ?

 

[Staple1600]

Bonsoir le fil, le forum

@Jean Peter Pek [Bienvenue sur le forum]
Quand l'aide tarde à venir, ne pas hésiter à ajouter explications supplémentaires et détails.

Si malgré tout, l'aide ne vient toujours pas, allumer une bougie et prier Sainte-Rita ou jeter du gros sel de la main gauche par dessus son épaule droite en criant "Option Explicit"

NB: Ton fichier Extraction est bizarre
Il est en *.xlsx et il affiche Macros désactivées
Tu peux le remplacer par une version en *.xlsm (avec les macros* qui devaient précédemment être présentes)
Merci.

*Copie_Ligne et Choix_Fichiers

EDITION: En attendant ton fichier *.xlsm

Bonjour à tous !
3- Par la suite, je souhaite supprimer les lignes ayant aucune information dans les colonne E & F (Valeur 8 et 9, les colonnes de couleur verte dans le fichier "Les données")

La macro ci-dessous fait cela

Sub Simili_Filtrage()
Dim f As Worksheet: Set f = Sheets("Informations")
Application.ScreenUpdating = False
   With f.Range("G2:G" & f.Cells(Rows.Count, "A").End(xlUp).Row)
    .FormulaR1C1 = "=IF(COUNTA(RC[-2]:RC[-1])=0,""$"",0)"
    .Value = .Value
    .SpecialCells(xlCellTypeConstants, 2).EntireRow.Delete
End With
f.Columns(7).ClearContents
End Sub

 

[job75]

Bonjour Jean Peter Pek, JM,

Voyez les fichiers joints et cette macro :

Sub Extract()
Dim F As Worksheet, fichier As Variant
Set F = Feuil16 'CodeName de la feuille "Informations", à adapter
fichier = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
If fichier = False Then Exit Sub
Application.ScreenUpdating = False
With Workbooks.Open(fichier).Sheets(F.Name)
    .[G2] = "=COUNTA(E2:F2)" 'critère de filtrage
    .[A:F].AdvancedFilter xlFilterCopy, .[G1:G2], F.[A1:F1] 'filtre avancé
    .Parent.Close False
End With
F.Activate 'facultatif
End Sub

Elle utilise le filtre avancé pour ne copier que les lignes renseignées en colonnes E ou F du fichier Les données.xlsx.

A+

 

[Staple1600]

Bonjour job75

Juste pour ma gouverne (si tu veux bien stp éclairer ma lanterne)
Est que comme chez moi (Excel 2013+W10) quand tu ouvres le fichier Extraction des données.xlsx du message#1, tu vois ceci s'afficher?
Normalement puisqu'il s'agit d'un *.xlsx, il n'y pas de projet VBA ???
(et sauf erreur de ma part, ce classeur ne comprends pas de feuille Macro XL4)
Donc comment est-ce possible qu'Excel affiche cet avertissement ?
C'est un bug ou une subtilité m'échappe ?

NB: Les options d' Excel sont réglées sur:
Les 3 options du Mode protégé sont cochées
Paramètres des macros: Désactiver toutes les macros avec notification.
Barre des messages: Premier choix coché

PS: J'ai bien vu que les deux "boutons" pointaient sur des macros
(cf le message#3)
Serait-ce là l'explication ?

 

[job75]

Re JM,

Chez moi aussi, à l'ouverture du .xlsx, j'ai le message relatif aux macros...

C'est sûrement dû aux boutons.

A+

 

[job75]

Re,

Ceci va mieux si le fichier choisi est déjà ouvert quand on lance la macro :

Sub Extract()
Dim F As Worksheet, fichier As Variant, wb As Workbook, ferme As Boolean
Set F = Feuil16 'CodeName de la feuille "Informations", à adapter
fichier = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
If fichier = False Then Exit Sub
Application.ScreenUpdating = False
F.[A:F].Clear 'RAZ
On Error Resume Next
Set wb = Workbooks(Mid(fichier, InStrRev(fichier, "\") + 1))
If wb Is Nothing Then Set wb = Workbooks.Open(fichier): ferme = True
With wb.Sheets(F.Name)
    .[H2] = "=COUNTA(E2:F2)" 'critère de filtrage
    .[A:F].AdvancedFilter xlFilterCopy, .[H1:H2], F.[A1:F1] 'filtre avancé
    .[H2] = ""
End With
If ferme Then wb.Close False 'si le fichier n'était pas ouvert
F.Activate 'facultatif
End Sub

Fichier (2).

Edit : les fichiers étaient sans doute vérolés, je les ai reconstruits, ils sont maintenant très légers...

A+

 

[job75]

Bonjour Jean Peter Pek, JM, le forum,

Compléments si les données sont organisées en tableau Excel :

Sub Extract()
Dim F As Worksheet, fichier As Variant, wb As Workbook, ferme As Boolean, styl As String
Set F = Feuil16 'CodeName de la feuille "Informations", à adapter
fichier = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
If fichier = False Then Exit Sub
Application.ScreenUpdating = False
F.Cells.Delete 'RAZ
On Error Resume Next
Set wb = Workbooks(Mid(fichier, InStrRev(fichier, "\") + 1))
If wb Is Nothing Then Set wb = Workbooks.Open(fichier): ferme = True
With wb.Sheets(F.Name)
    .[H2] = "=COUNTA(E2:F2)" 'critère de filtrage
    .[A:F].AdvancedFilter xlFilterCopy, .[H1:H2], F.[A1:F1] 'filtre avancé
    .[H2] = ""
    styl = .ListObjects(1).TableStyle 'si tableau Excel
End With
If ferme Then wb.Close False 'si le fichier n'était pas ouvert
With F.ListObjects.Add(xlSrcRange, F.UsedRange, , xlYes)
    .Name = "Tableau1"
    .TableStyle = styl
End With
F.Columns.AutoFit 'ajustement largeur
F.Activate 'facultatif
End Sub

Fichier (3).

Bonne journée.

 

[job75]

Bonjour le forum,

Pour terminer voici une solution avec formule de liaison qui évite d'ouvrir le fichier :

Sub Extract()
Dim F As Worksheet, fichier As Variant, i&, x$, tablo, n&, j%
Set F = Feuil16 'CodeName de la feuille "Informations", à adapter
fichier = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
If fichier = False Then Exit Sub
Application.ScreenUpdating = False
F.Cells.Delete 'RAZ
i = InStrRev(fichier, "\")
x = "'" & Left(fichier, i) & "[" & Mid(fichier, i + 1) & "]" & F.Name & "'!"
On Error Resume Next
i = ExecuteExcel4Macro("MATCH(""zzz""," & x & "C1)") 'dernière ligne
With F.[A1].Resize(i, 6)
    .FormulaArray = "=" & x & .Address 'formule de liaison matricielle
    tablo = .Value
    For i = 1 To UBound(tablo)
        If tablo(i, 5) <> 0 Or tablo(i, 6) <> 0 Then
            n = n + 1
            For j = 1 To 6
                tablo(n, j) = IIf(tablo(i, j) = 0, "", tablo(i, j))
            Next j
        End If
    Next i
    .ClearContents 'RAZ
    .Resize(n) = tablo 'restitution
End With
With F.ListObjects.Add(xlSrcRange, F.UsedRange, , xlYes)
    .Name = "Tableau1"
    .TableStyle = "TableStyleMedium13" 'style modifiable
End With
F.Columns(3).Resize(, 4).HorizontalAlignment = xlCenter 'centrage
F.Columns.AutoFit 'ajustement largeur
F.[H1] = fichier
F.Activate 'facultatif
End Sub

Fichier (4).

Avec des données sur 100 lignes l'exécution est 3 à 4 fois plus rapide (0,13 seconde chez moi).

Mais sur 100 000 lignes :

- fichier (3) => 3,4 secondes

- fichier (4) => 6,3 secondes.

A+