XL 2016 Afficher les résultats d'un tableau dans un autre

Bobleesouf

XLDnaute Nouveau
Salut!
Ce que je cherche exactement c'est afficher la dernière résultats de chaque PR pour chaque agents ?
et s'il est possible afficher la date dans chaque cellules (option non obligatoire).
et merci d'avance.

Dans un forum ils m'ont donnés ce code, mais je veux l'adapter si les tableaux des agents ne se trouvent pas sur le même ficher :

Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim PL(1 To 3) As Range 'déclare le tableau de 3 variables (PLages)
Dim PLR As Range 'déclare la variable PLR (PLage des Résultats)
Dim A As Byte 'déclare la variable A (Agent)
Dim PR As Byte 'déclare la variable PR
Dim COL As Integer 'déclare la variable COL (COLonne)

Set O = Worksheets("Feuil2") 'définit l'onglet O
Set PL(1) = O.Range("B3:F8") 'définit la plage PL(1)
Set PL(2) = PL(1).Offset(0, 7) 'définit la plage PL(2)
Set PL(3) = PL(2).Offset(0, 7) 'définit la plage PL(3)
Set PLR = O.Range("B14:F16") 'définit la plage PLR
For A = 1 To 3 'boucle 1 : sur les 3 lignes des agents
For PR = 1 To 5 'boucle 2 : sur les 5 lignes des PR
For COL = 5 To 1 Step -1 'boucle inversée 3 : sur les 5 colonnes des dates en partant de la dernière
If PL(A).Cells(PR + 1, COL).Value <> "" Then 'condition : si la valeur de la cellule en ligne PR, colonne COL de la plage PL(A) n'est pas vide
PLR(A, PR) = PL(A).Cells(1, COL) 'renvoie dans la cellule ligne A colonne PR de la plage PLR la date correspondante
PLR(A, PR).Interior.Color = PL(A).Cells(PR + 1, COL).DisplayFormat.Interior.Color 'récupère la couleur de la MFC
PLR(A, PR).NumberFormat = "dd/mm/yyyy" 'formate la date
Exit For 'sort de la boucle 3
End If 'fin de la condition
Next COL 'prochaine colonne de la boucle 3
Next PR 'prochaine ligne de la boucle 2
Next A 'prochaine ligne de la boucle 3
End Sub


Ce code ça marche bien pour mon 1er exemple (Les tableaux se trouvant sur la même feuille), maintenant je veux l'adapter pour le cas (Les tableaux des PR de agents sont séparés)

Merçi d'avance
 

Pièces jointes

  • agent 1.xlsx
    8.7 KB · Affichages: 6
  • agent 2.xlsx
    8.7 KB · Affichages: 5
  • agent 3.xlsx
    8.7 KB · Affichages: 3
  • exemple plan veille (1).xlsx
    10.9 KB · Affichages: 5

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Bobleesouf,
Un exemple de copie paste de données d'autres fichiers :
VB:
Sub CopyAgent()
' ouverture fichier agent
    Set wk1 = Workbooks.Open("C:\Users\PC_PAPA\Desktop\agent 1.xlsx")   ' A adapter
    Set wk2 = Workbooks.Open("C:\Users\PC_PAPA\Desktop\agent 2.xlsx")   ' A adapter
    Set wk3 = Workbooks.Open("C:\Users\PC_PAPA\Desktop\agent 3.xlsx")   ' A adapter
' copie des données
    wk1.Sheets("Feuil1").Range("A1:F8").Copy ThisWorkbook.Sheets("RecapAgent").Range("A1")
    wk2.Sheets("Feuil1").Range("A1:F8").Copy ThisWorkbook.Sheets("RecapAgent").Range("H1")
    wk3.Sheets("Feuil1").Range("A1:F8").Copy ThisWorkbook.Sheets("RecapAgent").Range("O1")
' fermeture des fichiers agent
    wk1.Close
    wk2.Close
    wk3.Close
End Sub
Ne fait que copier, ne calcule pas la matrice A13:F16.

Par contre si vous avez beaucoup d'agents il faut utiliser une fonction pour être plus simple à écrire.
C'est le cas ?
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Dans le cas où vous auriez beaucoup d'agent :
Code:
Sub CopieToutAgent()
Dim Liste()
' Déclaration de la racine du fichier, doit se terminer par \
    Racine = "C:\Users\PC_PAPA\Desktop\"                    ' A adapter
' Declaration des noms de fichiers
    ListeFichiers = Array("agent 1.xlsx", "agent 2.xlsx")   ' Rajouter tous les agents
' Nombre de fichiers déclarés
    Taille = UBound(ListeFichiers)
' Lancement écriture données
    For NoFichier = 0 To Taille
        Ligne = 9 * NoFichier + 1                                       ' Calcule le NO de ligne où coller
        Set wk = Workbooks.Open(Racine & ListeFichiers(NoFichier))      ' Construit le chemin d'accés
        wk.Sheets("Feuil1").Range("A1:F8").Copy ThisWorkbook.Sheets("RecapAgent").Range("A" & Ligne)    ' Colle données
        wk.Close     ' Ferme le fichier
    Next NoFichier
End Sub
J'ai mis les agents en verticale. Pour les avoir en horizontal modifier le calcul de Ligne en Colonne.
Mais avec plein d'agents je pense que c'est plus lisible de les avoir en verticale. A vous de voir.
 

Bobleesouf

XLDnaute Nouveau
Bonjour sylvanu,
Je pense que tu n'as pas bien compris mon message, le code que j'ai posé ça marche bien dans ce cas (voir PJ "exemple plan veille2.xlsm") où les tableau ce trouve dans la même feuille, (le tableau "A13:F16" prend la couleur + la date de chaque PR pour chaque agents, après tu appui sur "Actualiser" pour exécuter le Macro.
Maintenant je veux déplacer les tableaux des agents vers des fichiers séparés (chaque agent avec son fichier) et garder la même fonction sans ouvrir par exemple tous les fichiers.
et merci
 

Pièces jointes

  • exemple plan veille2.xlsm
    20.4 KB · Affichages: 5

sylvanu

XLDnaute Barbatruc
Supporter XLD
Vous avez mise à jour la macro ? Ce n'est pas du tout cuit. Il faut lui dire quoi faire.
En particulier modifier la racine ainsi que la liste des fichiers.
VB:
Dim Liste()
' Déclaration de la racine du fichier, doit se terminer par \
    Racine = "C:\Users\PC_PAPA\Desktop\"                    ' A adapter
' Declaration des noms de fichiers
    ListeFichiers = Array("agent 1.xlsx", "agent 2.xlsx")   ' Rajouter tous les agents
Je l'ai testée sur 3 agents, et ça marche correctement.
XL donne une erreur sur quelle ligne ?
 

Bobleesouf

XLDnaute Nouveau
Est ce qu'il faut modifier d'autre choses la ?

Sans titre.png


Voilà le message d'erreur :
Capture.PNG
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Ci joint un dossier avec trois agents. Il suffit de modifier la ligne
Racine = "C:\Users\PC_PAPA\Desktop\Dossier\" avec votre emplacement.
Je l'ai testé, retesté et ça marche.
Pouvez vous tester en gardant le même dossier et les même fichiers ?
 

Pièces jointes

  • Dossier.zip
    38.9 KB · Affichages: 3

Discussions similaires

Haut Bas