Remplacer la fonction Indirect par une macro VBA

billylooping

XLDnaute Nouveau
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

1595449327169.png


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

1595449345111.png


  • 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

1595449356334.png


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.
 

Pièces jointes

  • Macro Besoin indicateur Activité.xlsx
    54.2 KB · Affichages: 7

chris

XLDnaute Barbatruc
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
 
Dernière édition:

job75

XLDnaute Barbatruc
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 :
VB:
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+
 

Pièces jointes

  • Macro Besoin indicateur Activité(1).xlsm
    65.6 KB · Affichages: 8
Dernière édition:

job75

XLDnaute Barbatruc
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+
 

Pièces jointes

  • Macro Besoin indicateur Activité(1).xlsm
    65.6 KB · Affichages: 6
  • 05 UAP Assemblage et Tradition.zip
    952.8 KB · Affichages: 7

job75

XLDnaute Barbatruc
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 :
VB:
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
 

Pièces jointes

  • Macro Besoin indicateur Activité(2).xlsm
    65 KB · Affichages: 6
  • 05 UAP Assemblage et Tradition.zip
    952.8 KB · Affichages: 3
Dernière édition:

job75

XLDnaute Barbatruc
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

XLDnaute Barbatruc
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+
 

Pièces jointes

  • Macro Besoin indicateur Activité(3).xlsm
    62.4 KB · Affichages: 2
  • 05 UAP Assemblage et Tradition.zip
    952.8 KB · Affichages: 2

chris

XLDnaute Barbatruc
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
 

Pièces jointes

  • Besoin indicateur Activité_PQ.xlsx
    81.1 KB · Affichages: 7

billylooping

XLDnaute Nouveau
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
 

Discussions similaires

Statistiques des forums

Discussions
313 198
Messages
2 096 134
Membres
106 504
dernier inscrit
Kannankin Maxime