Remplacer la fonction Indirect par une macro VBA

[billylooping]

Bonjour,

je souhaite passer mon fichier comportant des formules avec la fonction "Indirect" et donc d'avoir les fichiers Excel liés systématiquement ouvert pour la mise à jour à une macro en gardant ces mêmes fichiers mais fermés. Le problème est que je ne sais pas encore faire ce type de macro.

Pour chaque Secteur de notre entreprise, nous faisons un pointage en fonction du travail effectué.

Le fichier de pointage est nominatif par mois et par secteur : un fichier pour le secteur UAP Lustrerie pour le mois de janvier, un fichier pour le secteur UAP Lustrerie pour le mois de février …. Un fichier pour le secteur UAP Déco pour le mois de janvier, un fichier pour le secteur UAP Déco pour le mois de février…..

Le pointage se fait de manière quotidienne, nous remplissons chaque jour l'onglet de la date correspondant dans le fichier de pointage. Par exemple aujourd’hui nous somme le 6 janvier 2020 --> Je vais dans le fichier Janvier 2020 de l'UAP Deco, je rentre mes informations dans l'onglet 6 qui correspond au 6 janvier.

Chaque fichier à un chemin d’accès différents. Je n’ai pas la main sur ce point. Je n’ai pas la main pour modifier également le fichier de pointage. Je peux juste travailler sur le fichier Macro Besoin indicateur Activité.

Une fois le fichier remplie, je me sers de certaines valeurs du pointage pour remplir mon tableau d’activité. Dans certains cas j’utilise une valeur de l’onglet et dans d’autres cas je fais des additions de différentes valeurs dans ce même onglet.

J’arrive à faire le lien chemin - Fichier – onglet à l’aide de la date. En la décomposant par jour et par mois

Je souhaite dans le fichier

Remplir en automatique toutes les colonnes en jaune du fichier Macro Besoin indicateur Activité En fonction de la date et des fichiers de pointage.

En exemple

Macro Besoin indicateur Activité.xls

• Releve UAP Deco

Colonne D à Temps passé pour l’intitulé Taille déco, à la ligne 6 janvier

Reprendre la valeur dans

le fichier POINTAGES 2020\05 UAP Assemblage et Tradition\01 UAP Déco\01 JANVIER 2020\01 UAP Déco.xlsm - onglet 6 – Addition des 3 cellules suivantes : M5+O5+P5

Colonne J à Temps passé pour l’intitulé Choix Cond Deco, à la ligne 7 février

Reprendre la valeur dans

le fichier POINTAGES 2020\05 UAP Assemblage et Tradition\01 UAP Déco\02 FEVRIER 2020\01 UAP Déco.xlsm - onglet 7 – Copie cellule

• Releve UAP Lustrerie

Colonne D à Temps passé pour l’intitulé TAILLE LUSTRERIE, à la ligne 7 janvier

Reprendre la valeur dans

le fichier POINTAGES 2020\05 UAP Assemblage et Tradition\01 UAP Taille Lustrerie\01 JANVIER 2020\01 UAP Taille lustrerie.xlsm - onglet 7 – copie valeur cellule S7

Pour l’exemple, dans le fichier excel, j’ai supprimé les différents liens et formules pour partir sur quelque chose de propre. Dans le fichier compressé il y a également un exemple arborescence des fichiers sources.

Billy

Par avance je m'excuse car je n'ai pas construis de code VBA n'ayant pas encore les compétences.
Merci pour votre compréhension.

 

[chris]

Bonjour

Ces fichiers sont loin d’être normalisés : sans doute créés il y a longtemps et pas d'exploitation optimum

Avec 365, je partirais plutôt sur une solution PowerQuery intégré à Excel

Pas le temps avant lundi de regarder de plus près

 

[billylooping]

Merci de regarder mon problème.
J'avoue que Vba et PowerQuery mon sont des notions abstraite. un peu moins vba car je tente de me former^^.

Yohan

 

[job75]

Bonjour billylooping, chris,

Téléchargez le fichier .xlsm joint dans le même répertoire que le dossier "05 UAP Assemblage et Tradition".

Il y a un bouton "Mise à jour" dans chacune des 2 feuilles avec ces 2 macros :

Sub MAJ_Deco()
Dim chemin$, fichier$, conf As Boolean, fso As Object, sf As Object, f As Object
Dim i&, wb As Workbook, sh As Worksheet, x1, x2, x3, x4
chemin = ThisWorkbook.Path & "\05 UAP Assemblage et Tradition\01 UAP Déco\"
fichier = "## UAP Déco.xlsm" 'à adapter
'---ouverture de tous les fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
conf = Application.AskToUpdateLinks 'mémorise l'état
Application.AskToUpdateLinks = False 'évite le message
Set fso = CreateObject("Scripting.FileSystemObject")
For Each sf In fso.GetFolder(chemin).SubFolders
    For Each f In sf.Files
        If f.Name Like fichier Then Workbooks.Open chemin & sf.Name & "\" & f.Name
Next f, sf
Application.AskToUpdateLinks = conf 'restitue l'état
'---traitement du tableau---
With Feuil2 'CodeName à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    On Error Resume Next 'si le fichier n'existe pas
    For i = 7 To .Cells(Rows.Count, 1).End(xlUp).Row
        Set wb = Nothing: Set sh = Nothing: x1 = Empty: x2 = Empty: x3 = Empty: x4 = Empty
        Set wb = Workbooks(Replace(fichier, "##", Format(Month(.Cells(i, 1)), "00")))
        Set sh = wb.Sheets(CStr(Day(.Cells(i, 1))))
        x1 = Application.HLookup("Main", sh.Rows("4:5"), 2, 0)
        x2 = Application.HLookup("MACH", sh.Rows("4:5"), 2, 0)
        x3 = Application.HLookup("Robot", sh.Rows("4:5"), 2, 0)
        x4 = Application.HLookup("Cond", sh.Rows("4:5"), 2, 0)
        .Cells(i, 4) = IIf(x1 + x2 + x3, x1 + x2 + x3, "")
        .Cells(i, 10) = IIf(x4 = Empty, "", x4)
    Next
End With
'---fermeture des fichiers---
For Each wb In Workbooks
    If wb.Name <> ThisWorkbook.Name Then wb.Close False
Next
End Sub

Sub MAJ_Lustrerie()
Dim chemin$, fichier$, conf As Boolean, fso As Object, sf As Object, f As Object
Dim i&, wb As Workbook, sh As Worksheet
chemin = ThisWorkbook.Path & "\05 UAP Assemblage et Tradition\02 UAP Lustrerie\"
fichier = "## UAP Lustrerie.xlsm" 'à adapter
'---ouverture de tous les fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
conf = Application.AskToUpdateLinks 'mémorise l'état
Application.AskToUpdateLinks = False 'évite le message
Set fso = CreateObject("Scripting.FileSystemObject")
For Each sf In fso.GetFolder(chemin).SubFolders
    For Each f In sf.Files
        If f.Name Like fichier Then Workbooks.Open chemin & sf.Name & "\" & f.Name
Next f, sf
Application.AskToUpdateLinks = conf 'restitue l'état
'---traitement du tableau---
With Feuil3 'CodeName à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    On Error Resume Next 'si le fichier n'existe pas
    For i = 4 To .Cells(Rows.Count, 1).End(xlUp).Row
        Set wb = Nothing: Set sh = Nothing
        Set wb = Workbooks(Replace(fichier, "##", Format(Month(.Cells(i, 1)), "00")))
        Set sh = wb.Sheets(CStr(Day(.Cells(i, 1))))
        .Cells(i, 4) = IIf(sh.Range("S6") = Empty, "", sh.Range("S6"))
    Next
End With
'---fermeture des fichiers---
For Each wb In Workbooks
    If wb.Name <> ThisWorkbook.Name Then wb.Close False
Next
End Sub

Cliquez sur les boutons, le remplissage des cellules jaunes n'est pas très rapide.

A+

 

[job75]

Bonjour le forum,

Pour que le dossier "05 UAP Assemblage et Tradition" zippé fasse moins de 1 Mo j'ai supprimé le fichier relatif au mois de février 02 UAP Déco.xlsm.

Maintenant je peux donc le déposer ici, c'est mieux que le site d'hébergement.

A+

 

[job75]

L'ouverture de tous les fichiers prendra vraiment trop de temps.

Avec ce fichier (2) on évite de les ouvrir en utilisant des formules de liaison calculées :

Sub MAJ_Deco()
Dim chemin$, fichier$, i&, dossier$, fich$, feuille$, formule$, x1, x2, x3, x4
chemin = ThisWorkbook.Path & "\05 UAP Assemblage et Tradition\01 UAP Déco\"
fichier = "## UAP Déco.xlsm" 'à adapter
Application.ScreenUpdating = False
With Feuil2 'CodeName à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    For i = 7 To .Cells(Rows.Count, 1).End(xlUp).Row
        dossier = UCase(Replace(Replace(Format(.Cells(i, 1), "mm mmmm yyyy"), "é", "e"), "û", "u")) & "\" 'majuscules sans accents
        fich = Replace(fichier, "##", Format(Month(.Cells(i, 1)), "00"))
        If Dir(chemin & dossier & fich) <> "" Then
            feuille = Day(.Cells(i, 1))
            formule = "HLOOKUP(""?"",'" & chemin & dossier & "[" & fich & "]" & feuille & "'!R4:R5,2,0)"
            x1 = ExecuteExcel4Macro(Replace(formule, "?", "Main"))
            x2 = ExecuteExcel4Macro(Replace(formule, "?", "MACH"))
            x3 = ExecuteExcel4Macro(Replace(formule, "?", "Robot"))
            x4 = ExecuteExcel4Macro(Replace(formule, "?", "Cond"))
            .Cells(i, 4) = IIf(x1 + x2 + x3, x1 + x2 + x3, "")
            .Cells(i, 10) = IIf(x4, x4, "")
        End If
    Next
End With
End Sub

Sub MAJ_Lustrerie()
Dim chemin$, fichier$, i&, dossier$, fich$, feuille$, x
chemin = ThisWorkbook.Path & "\05 UAP Assemblage et Tradition\02 UAP Lustrerie\"
fichier = "## UAP Lustrerie.xlsm" 'à adapter
Application.ScreenUpdating = False
With Feuil3 'CodeName à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    For i = 4 To .Cells(Rows.Count, 1).End(xlUp).Row
        dossier = UCase(Replace(Replace(Format(.Cells(i, 1), "mm mmmm yyyy"), "é", "e"), "ô", "o")) & "\" 'majuscules sans accents
        fich = Replace(fichier, "##", Format(Month(.Cells(i, 1)), "00"))
        If Dir(chemin & dossier & fich) <> "" Then
            feuille = Day(.Cells(i, 1))
            x = ExecuteExcel4Macro("'" & chemin & dossier & "[" & fich & "]" & feuille & "'!R6C19")
            .Cells(i, 4) = IIf(x, x, "")
        End If
    Next
End With
End Sub

 

[job75]

J'ai testé la 1ère macro sur 366 jours avec les 12 fichiers sources, durées d'exécution chez moi :

- fichier (1) avec ouvertures => 63 secondes

- fichier (2) sans ouvertures => 7,5 secondes.

Avec la solution PowerQuery que chris va étudier ce devrait être plus rapide.

 

[job75]

Bonjour,

Dans ce fichier (3) les 2 macros sont lancées automatiquement par une Workbook_Activate.

Elles s'exécutent donc à l'ouverture du fichier et quand il est activé.

A+

 

[billylooping]

Merci pour votre aide. Je suis en wé vacances sans ordinateur. Je regarde vos propositions lundi. Merci beaucoup pour vos aides. Yohan

 

[chris]

Bonjour à tous

Une solution PowerQuery (intégré à ta version Excel)
Indiquer le chemin du dossier racine et l'année dans l'onglet Paramètres puis Données, Actualiser Tout

La structure de Lustrerie est un peu différente de celle de Déco : j'espère que c'est homogène dans chaque sous-dossier

 

[billylooping]

Merci @job 75 pour le fichier.
Malheureusement sur mon ordinateur , la mise à jour des données prend 3 min se qui est un peu long. Mais le code fonctionne bien.
Je vais plutôt utiliser la technique Power Query de chris.
Merci Chris pour le travail, il correspond à ma demande, je suis en train de l'adapter sur d'autres fichiers.

Un grand merci à Job 75 et Chris pour m'avoir donné un coup de main.

Yohan