Autre besoin de regroupement de plusieurs fichiers

Bonjour le forum d'entraide Excel-pratique,

J'ai un autre besoin de regroupement de plusieurs fichiers:

Sur un regroupements d'une dizaine de fichiers que je veux ciblé dans des répertoires défini sachant que dans ces répertoires j'ai d'autre fichiers que je ne veux pas requêter.

exemple mais fichiers se trouve dans :

S:\Suivis\FaD\384x298 LTW\384x298 LTW CANTO.xls

S:\Suivis\FaD\520x612 MW\520x612 MW-CH111.xls

S:\Suivis\FaD\MIPOD\MIPOD-CH286A.xls

PS : tous les fichiers on, une feuille nommée (FAD)

avec en titre colonne A => année, en B => mois, en C => n° de la semaine

Le besoin serait de regrouper tout les fichiers par rapport à l'année et le N° de semaine.

https://www.excel-pratique.com/~files/doc2/rech_FAD.zip

cordialement merci d'avance

Franck

Bonjour le forum,

j'ai trouvé du code mais le pb c'est que les classeurs doivent tous être dans le même dossier...

voici

Sub regroup()
Dim i As Long, f As String
f = Dir("*.xls")
Do While Len(f) > 0
Workbooks.Open (f)
With Worksheets("FAD")
.Range("C5", .[A65536].End(xlUp).Address).Copy _
Destination:=ThisWorkbook.Sheets("Feuil1").[A65536].End(xlUp)(2)
Workbooks(f).Close False
End With
f = Dir
Loop
End Sub 

merci de votre aide

Salut franck, forum,

Je vois que ton post ne rencontre pas trop de succès

Un manque d'informations peut-être?

Voici un début de solution avec un GetOpenFileName. C'est-à-dire que tu choisis le fichier à ouvrir.

Fichier

À toi d'essayer de l'adapter franck.

Salut a toi l'ami...

je pédale toujours hihihihii

sinon j'ai toujours pas trouvé pour allez chercher mes fichiers dans des repertoires spécifique...

sinon ton code ne fonctionne pas chez moi es-ce normal?

A+

re,

tu ne dis pas quel est le problème franck

Difficile donc de deviner!

Quelle est l'erreur retournée, à quelle ligne?

PS : j'ai difficilement accès à internet durant la semaine. Ne sois donc pas étonné si je ne réponds pas

Salut Mr vba-new,

OK pour la macro elle fonctionne très bien si je sélectionne un par un mes fichiers.

1/ Par contre puis-je cibler dans la macro en automatique les liens des classeurs comme si dessous :

= "E:\Documents and Settings\Bureau\Charger liste_2\FAD\384x288 LW.xls"

= "E:\Documents and Settings\Bureau\Charger liste_2\FAD\Copie de 384x288 LW.xls"

= "E:\Documents and Settings\Bureau\Charger liste_2\FAD\288x4 LW.xls"

2/ est il possible de noter (E:\Documents and Settings\Bureau\Charger liste_2\FAD\384x288 LW.xls) à la place de (384x288 LW.xls)

3/ lors de l'appel de la macro (test) faire un vidage de l'ex zone de transfert

4/ copier les valeurs des tableaux source mais pas copier les cadres ou bordures...

voila les quelques lignes...

cordialement F.

Bonjour franck, forum,

Un peu long le temps de réponse mais voici une macro qui résout les points 2,3 et 4.

Remplace la macro existante par celle-ci :

'Option Explicit
Sub test()
Dim critDeb As String, critFin As String, crit2 As String
Dim i As Long, x As Long
critDeb = Cells(1, 3)    'critère semaine en C1
critFin = Cells(1, 6)    'critère semaine en F1
crit2 = Cells(2, 9)    'critère année en I2

    Application.ScreenUpdating = False
    Rows("5:65536").Delete Shift:=xlUp
    Set maitre = ActiveWorkbook
    Path = ThisWorkbook.Path & "\"
    ChDir Path
    'fichier = Dir(Path & "*.xls")
    fichier = Application.GetOpenFilename("fichiers XLS,*.xls")

    'Do While fichier <> "" And fichier <> "rech_FAD_v1.xls"
    Do While fichier <> False And InStr(fichier, ThisWorkbook.Name) = 0
        i = Range("A65536").End(xlUp).Row + 1
        'Workbooks.Open Filename:=Path & fichier
        Workbooks.Open Filename:=fichier
        nomFichier = ActiveWorkbook.Name
        Sheets("FAD").Activate

        For x = critDeb To critFin
            [A1].AutoFilter Field:=3, Criteria1:=x
            [A1].AutoFilter Field:=1, Criteria1:=crit2
            On Error Resume Next    'gère l'erreur lorsqu'il ne trouve pas le numéro de semaine
            Range("_FilterDataBase").Offset(1, 0).Resize(Range("_FilterDataBase"). _
                                                         Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
            maitre.Sheets("rech_FAD").[A65000].End(xlUp).Offset(1, 0).PasteSpecial _
                    Paste:=xlPasteAllExceptBorders
        Next x
        Workbooks(nomFichier).Close savechanges:=False

        Do While Cells(i, 1) <> ""
            Cells(i, 11) = fichier    'pour mettre le chemin du fichier
            i = i + 1
        Loop
        'mets les bordures
        With Range("A" & i - 1 & ":I" & i - 1 & ",K" & i - 1).Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With

        'fichier = Dir
        fichier = Application.GetOpenFilename("fichiers XLS,*.xls")

    Loop
End Sub

Pour le point 1, je t'avoue que je ne sais pas trop faire.

Je vais tenter d'y réfléchir! Bien que pas trop de temps ces temps-ci.

A+

Salut Mr VBA New

Ce matin j'ai un problème je n'arrive plus à utiliser 'rech_FAD_v1.xls'

de plus impossible d'utiliser le second code que tu as fais, sais d'où ça viens ce pb.

F.

Bonjour franck, forum,

Concernant ce problème, je ne sais pas du tout!

D'autant qu'il manque des informations!

Sois plus précis, afin d'optimiser les chances de t'aider.

bonsoir à tous,

pour mon problème ça viens du module utilitaire d'analyse-VBA non installé sur ce pc

1/ sinon lors du changement d'année j'ai un bug sur le vidage

    Rows("5:65536").Delete Shift:=xlUp

2/ je n'ai plus de bordure cadre mes des lignes souligné entre les fichiers

3/ puis-je cibler dans la macro en automatique les liens des classeurs comme si dessous :

= "E:\Documents and Settings\Bureau\Charger liste_2\FAD\384x288 LW.xls"
= "E:\Documents and Settings\Bureau\Charger liste_2\FAD\Copie de 384x288 LW.xls"
= "E:\Documents and Settings\Bureau\Charger liste_2\FAD\288x4 LW.xls"
...

4/ si la semaine n'est pas trouvé est il possible de chercher l'inferieur :

        For x = critDeb To critFin

comme ceci

        For x = critDeb <> critFin 'comprise entre critDeb et critFin

merci [/code]

bonsoir VBA new plus de nouvelles sur le sujet?