Microsoft 365 Séparer les données d'un fichier Source en fonction de la valeur dans une colonne

[Magnio]

Bonjour à tous,

J'ai tenté de faire ce projet mais je me heurte à une difficulté (ou plutôt un manque de connaissances de ma part ^^) qui requièrent votre aide.

Le fichier principal est Séparation Rapports, on clique sur le bouton Rouge et on va choisir le fichier REQUETE v1 d'où extraire les données.

Le but: en fonction de la valeur de la cellule en colonne H, trier les données et les incrémenter au fil de l'eau dans les onglets appropriés.
(Vous pouvez voir le résultat souhaité dans le fichier: Séparation Rapports Résultats Souhaités)

Je sais aller piocher la valeur d'une cellule en fonction d'une autre, mais je n'ai encore jamais expérimenter de sélectionner une ligne entière (du moins dans ce cas précis de la colonne B à S).

Si quelqu'un peut éclairer ma lanterne, cela me sera très utile et me fera progresser dans mes connaissances en VBA.
Merci. =)

 

[sylvanu]

Bonjour Magnio,
Un essai en PJ, la macro est commentée.
Si problème, exposez le souci avec précision.

 

[Magnio]

Bonjour Magnio,
Un essai en PJ, la macro est commentée.
Si problème, exposez le souci avec précision.

Ça fonctionne. Je n'avais pas pensé à définir un tableau, simple mais efficace.

Mais il faudrait effectuer une modification; et c'est de ma faute car j'ai oublié de le préciser; il faudrait que cela s'incrémente au fur et à mesure que je charge des Requêtes.

 

[sylvanu]

Mais il faudrait effectuer une modification; et c'est de ma faute car j'ai oublié de le préciser; il faudrait que cela s'incrémente au fur et à mesure que je charge des Requêtes.

Voir PJ. Par contre si on fait l'opération plusieurs fois sur le même fichier on recopie plusieurs fois les mêmes données.
Et je ne vois pas quelle sécurité mettre en place pour éviter cela.
Vos fichiers sources peuvent ils porter quelquefois le même nom, ou les noms seront ils toujours différents ?

 

[sylvanu]

Re,
Ai je le droit d'écrire dans le fichier requêtes avant de le fermer ?
Par exemple mettre en A1 la date et en B1 "Fichier déjà traité."
Il suffit alors de lire ces cellules avant exportation ou non.
Voir essai en PJ.

 

[Magnio]

Alors il n'y avait aucun problème au fait de pouvoir recopier plusieurs fois les mêmes données, car peut-être que cela arrivera un jour.
Mais la proposition v4 est parfaite avec ce garde-fou qui vérifie si le fichier a déjà été importé ou non. (Et au pire, si on veut réinjecter les valeurs dans la macro, il suffit de supprimer le contenu des cellules A1 et B1 ^^)

Un grand merci à toi! 🙂

 

[job75]

Bonsoir Magnio, sylvanu,

On peut importer et filtrer par le filtre automatique tous les fichiers .xlsx situés dans un même dossier.

Avec cette solution le fichier .xlsm de la macro doit être dans ce même dossier :

Sub ImporterFiltrer()
Dim t, F1 As Worksheet, F2 As Worksheet, chemin$, fichier$, n, dest As Range
t = Timer
Set F1 = Sheets("Inférieur 0,4")
Set F2 = Sheets("Supérieur 0,4")
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Application.ScreenUpdating = False
F1.Rows("5:" & Rows.Count).Delete 'RAZ
F2.Rows("5:" & Rows.Count).Delete 'RAZ
While fichier <> ""
    With Workbooks.Open(chemin & fichier).Sheets(1)
        n = n + 1
        With .Range("B4:S" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
            .AutoFilter 7, "<=0.4" 'filtre la 7ème colonne (H)
            Set dest = F1.Cells(F1.Cells(F1.Rows.Count, 8).End(xlUp).Row + 1, 2)
            .Offset(1).Copy dest 'copier-coller des cellules visibles
            .AutoFilter 7, ">0.4"
            Set dest = F2.Cells(F2.Cells(F2.Rows.Count, 8).End(xlUp).Row + 1, 2)
            .Offset(1).Copy dest
        End With
        .Parent.Close False 'ferme le fichier
    End With
    fichier = Dir 'fichier suivant
Wend
MsgBox n & " fichiers importés et filtrés en " & Format(Timer - t, "0.00 \sec")
End Sub

Bonne nuit.

 

[job75]

Bonjour le forum,

S'il y a beaucoup de fichiers .xlsx à traiter la macro précédente prendra pas mal de temps.

C'est dû au fait qu'il faut ouvrir et fermer chaque fichier.

Pour aller vite il faut utiliser des fichiers CSV et les ouvrir en lecture séquentielle :

Sub ImporterFiltrer()
Dim t, F1 As Worksheet, F2 As Worksheet, chemin$, fichier$, n, x%, texte$, s, a(), i&, j%, v, b(), ii&, c(), k&
t = Timer
Set F1 = Sheets("Inférieur 0,4")
Set F2 = Sheets("Supérieur 0,4")
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.csv") '1er fichier du dossier
While fichier <> ""
    n = n + 1
    x = FreeFile
    Open chemin & fichier For Input As #x 'ouverture en lecture séquentielle
    While Not EOF(x)
        Line Input #x, texte
        s = Split(texte, ";")
        If IsNumeric(s(6)) Then ' colonne G
            If CDbl(s(6)) <= 0.4 Then
                i = i + 1
                ReDim Preserve a(1 To 18, 1 To i)
                For j = 1 To 18
                    v = s(j - 1)
                    If j = 4 Then
                        If IsDate(v) Then a(j, i) = CDate(v)
                    Else
                        If IsNumeric(v) Then a(j, i) = CDbl(v) Else a(j, i) = v
                    End If
                Next j
            Else
                ii = ii + 1
                ReDim Preserve b(1 To 18, 1 To ii)
                For j = 1 To 18
                    v = s(j - 1)
                    If j = 4 Then
                        If IsDate(v) Then b(j, ii) = CDate(v)
                    Else
                        If IsNumeric(v) Then b(j, ii) = CDbl(v) Else b(j, ii) = v
                    End If
                Next j
            End If
        End If
    Wend
    Close #x
    fichier = Dir 'fichier suivant
Wend
'---transpositions et restitutions---
If i Then
    ReDim c(1 To i, 1 To 18)
    For k = 1 To i: For j = 1 To 18: c(k, j) = a(j, k): Next j, k
    F1.[B5].Resize(i, 18) = c
End If
If ii Then
    ReDim c(1 To ii, 1 To 18)
    For k = 1 To ii: For j = 1 To 18: c(k, j) = b(j, k): Next j, k
    F2.[B5].Resize(ii, 18) = c
End If
'---RAZ en dessous---
F1.[B5].Offset(i).Resize(F1.Rows.Count - i - 4, 18).ClearContents
F2.[B5].Offset(ii).Resize(F2.Rows.Count - ii - 4, 18).ClearContents
MsgBox n & " fichiers importés et filtrés en " & Format(Timer - t, "0.00 \sec")
End Sub

A+

 

[Magnio]

Merci Job pour tes propositions. Approche intéressante, malheureusement l'architecture et la confidentialité des données professionnelles entre différentes Services font que le fichier de "tri" ne peut pas être dans le dossier des imports.
Encore merci de ta proposition. 🙂

 

[job75]

Bonjour Magnio, le forum,

Merci Job pour tes propositions. Approche intéressante, malheureusement l'architecture et la confidentialité des données professionnelles entre différentes Services font que le fichier de "tri" ne peut pas être dans le dossier des imports.

Allons Magnio ce n'est pas un problème il suffit d'adapter le chemin.

Si les fichiers à traiter sont dans le dossier "Import" vous pouvez écrire par exemple :

chemin = ThisWorkbook.Path & "\Import\" 'dossier à adapter

A+

 

[Magnio]

En effet si tous les fichiers étaient dans le même dossier.
Je n'ai pas donné tous les détails, mais les fichiers à importer sont dispersés sur le réseau, il faudrait écrire un bout de code par chemin d'accès.
De plus, je ne suis pas certains que les dossiers de destinations seront toujours les mêmes, ce qui obligerait à faire des modifications sans arrêts. ^^

 

[job75]

les fichiers à importer sont dispersés sur le réseau, il faudrait écrire un bout de code par chemin d'accès.

Alors utilisez FileDialog pour rechercher les dossiers que vous voulez, voyez les fichiers joints :

Set dossier = Application.FileDialog(msoFileDialogFolderPicker) 'recherche un dossier

Vous pouvez si nécessaire préciser les noms des fichiers avec l'instruction :

fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier

En fin de procédure les doublons éventuels sont supprimés.

 

[job75]

Remove.Duplicates introduit des cellules vides non formatées, il faut les supprimer :

'---supprime les lignes vides---
F1.Rows(F1.Range("H" & F1.Rows.Count).End(xlUp).Row + 1 & ":" & F1.Rows.Count).Delete
F2.Rows(F2.Range("H" & F2.Rows.Count).End(xlUp).Row + 1 & ":" & F2.Rows.Count).Delete

C'est impératif avec les fichiers CSV car seules les valeurs sont copiées.

 

[Magnio]

Alors utilisez FileDialog pour rechercher les dossiers que vous voulez, voyez les fichiers joints :

Set dossier = Application.FileDialog(msoFileDialogFolderPicker) 'recherche un dossier

Vous pouvez si nécessaire préciser les noms des fichiers avec l'instruction :

fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier

En fin de procédure les doublons éventuels sont supprimés.

Fichiers testés et modifiés pour les adapter à ma vraie Base de Données, ça marche au top et c'est très pratique de charger tous les fichiers du dossier en même temps. =)

 

[job75]

Heureux que mes solutions vous conviennent.

Dans cette dernière version les tableaux de restitution sont des tableaux structurés.

En dehors des tableaux la police de base est Calibri 11.

Edit : pour les fichiers .xlsx j'ai ajouté un test avant chaque filtration :

If Application.CountIf(.Columns(7), "<=0.4") Then 'vérifie qu'il y a des données à filtrer

et :

If Application.CountIf(.Columns(7), ">0.4") Then