Forum |  HardWare.fr | News | Articles | PC | S'identifier | S'inscrire | Shop Recherche
929 connectés 

  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  Macro unique pour plusieurs fichiers excels

 


 Mot :   Pseudo :  
 
Bas de page
Auteur Sujet :

Macro unique pour plusieurs fichiers excels

n°1589938
jackbauer9​72
Posté le 23-07-2007 à 09:23:22  profilanswer
 

Bonjour à toutes et à tous,
J’utilise un fichier excel qui s’occupe d’extraire des données issues de bancs de test.
Tous les différents bancs de test utilisent les mêmes macros. Je voudrais savoir s’il est possible de garder un seul fichier contenant les macros utiles et qu’ensuite les fichiers excels propres aux bancs de test viennent appeler cette unique macro. Le but est qu’en cas de modification du code, je n’aurai qu’à changer une seule fois le code.
Ma question est donc plus précisément, est-il possible de faire ceci, si plusieurs extractions de données sont lancées en même temps cela ne risque t’il pas de faire planter la macro ?
 
Merci
 
J'ai déjà essayé de réaliser un modèle excel .XLT mais le problème est que je n'arrive pas à modifier le .XLT car dès que je réalise une modification du code, ça ne met pas à jour le modèle d'origine mais ça m'en crée un nouveau. En fait je ne peux pas enregistrer par dessus. Je fais surement une erreur mais je ne sais pas où?

mood
Publicité
Posté le 23-07-2007 à 09:23:22  profilanswer
 

n°1589939
jpcheck
Pioupiou
Posté le 23-07-2007 à 09:26:28  profilanswer
 

bonjour,
peux-tu nous donner  quelques lignes de ton extraction pour voir ta manière de t'y prendre,
. On pourra en conséquence te proposer une solution appropriée :)

n°1589943
jackbauer9​72
Posté le 23-07-2007 à 09:37:16  profilanswer
 

Je suis pas certain que ça puisse t'aider beaucoup
 

Code :
  1. Sub Macro_Extract_data_Update()
  2. 'Lecture du login et du mot de passe dans les cellules G2 et G3
  3. 'ThisWorkbook.Activate
  4. 'Sheets("PARAMETRES" ).Select
  5. 'ActiveCell.Offset(1, 6).Value = Login
  6. 'ActiveCell.Offset(2, 6).Value = Password
  7. Ma_Reponse = MsgBox("Voulez-vous lancer l'extraction ?", vbYesNo)
  8. If Ma_Reponse = vbNo Then Exit Sub
  9. Dim NetR As NETRESOURCE
  10.     NetR.dwScope = RESOURCE_GLOBALNET
  11.     NetR.dwType = RESOURCETYPE_DISK
  12.     NetR.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
  13.     NetR.dwUsage = RESOURCEUSAGE_CONNECTABLE
  14.    
  15. 'Teste si les macros complementaires analysis toolpak sont installés (besoin pour calcul stat)
  16. Test_Si_Macro_Comp
  17. Sn_Différent = ""
  18. 'Initialisation de la feuile resultat_save
  19. ThisWorkbook.Activate
  20. Sheets("Résultat_Save" ).Visible = True
  21. Sheets("Résultat_Save" ).Select
  22. Range("A15" ).End(xlDown).Offset(1, 0).Activate
  23. Sheets("Résultat_Save" ).Visible = xlVeryHidden
  24. 'Détermination du nb de bancs et affectation des noms
  25. ThisWorkbook.Activate
  26. If Not IsEmpty(Range("Banc_N1" ).Offset(1, 0)) Then
  27. Nb_bancs = Range(Range("Banc_N1" ), Range("Banc_N1" ).End(xlDown)).Rows.Count
  28. Else: Nb_bancs = 1
  29. End If
  30. 'défini l'adresse des bancs.
  31. For k = 0 To Nb_bancs - 1
  32.     Adresse_Banc(k + 1) = Range("Banc_N1" ).Offset(k, 0).Value & "\"
  33.     Drive_Banc(k + 1) = ""
  34. Next k
  35.     ListAllDrives  'teste si la connexion existe et remplit drive_banc(x)
  36. 'teste les 3 bancs les uns après les autres
  37. 'initialisation recherche
  38.     ThisWorkbook.Activate
  39.     Sheets("extract" ).Select
  40.     Range("A2" ).Activate
  41.     Sheets("Résultat" ).Select
  42.     Range("A15" ).End(xlDown).Offset(1, 0).Activate
  43.     On Error Resume Next
  44.     Application.ScreenUpdating = False
  45. 'sauvegarde et mise à jour barre etat
  46.     BarreEtatEnregistrée = Application.DisplayStatusBar
  47.     Application.DisplayStatusBar = True
  48.     Application.StatusBar = "Veuillez patienter quelques instants..."
  49. 'init var pour savoir si un fichier a été ajouté
  50.     Test_Si_Fichier_Ouvert = False
  51. For N_Banc = 1 To Nb_bancs
  52.  
  53. 'ouvre la session reseau
  54.         Drive_Disconnect(N_Banc) = True
  55.         NetR.lpLocalName = Fisrt_Letter_Free ' si non défini se connecte sans device
  56.         NetR.lpRemoteName = Adresse_Banc(N_Banc) & "d$"
  57.         Application.StatusBar = "Je me connecte au réseau : Banc numéro : " & Adresse_Banc(N_Banc)
  58.        
  59. 'pour balayer de C28 à C38
  60. For NLigne = 28 To 38
  61.    Password = Worksheets("PARAMETRES" ).Range("D" & CStr(NLigne)).Text
  62.    Login = Worksheets("PARAMETRES" ).Range("C" & CStr(NLigne)).Text
  63.    ErrInfo = WNetAddConnection2(NetR, Password, Login, CONNECT_UPDATE_PROFILE)
  64. Next
  65.    
  66.         If ErrInfo <> NO_ERROR Then
  67.             CreateObject("wscript.shell" ).popup "ERROR: " & ErrInfo & " - Connection impossible sur le banc " & Adresse_Banc(N_Banc), 3, "Réseau non connecté"
  68.             ErrInfo = ""
  69.             GoTo Fin_Boucle_Banc
  70.         End If
  71.         Drive_Letter_Banc(N_Banc) = Fisrt_Letter_Free & "\"
  72.     Else
  73.         Application.StatusBar = "Je passe au Banc numéro : " & Adresse_Banc(N_Banc)
  74.         Drive_Letter_Banc(N_Banc) = Drive_Banc(N_Banc)
  75.         Drive_Disconnect(N_Banc) = False
  76.     End If
  77.   Set fs = Application.FileSearch
  78. ' definit le chemin de recherche des datas dans le rep \tmp (crée par chemin extraction)
  79. Chemin_Rech = Drive_Letter_Banc(N_Banc) & Range("Banc_N1" ).Offset(N_Banc - 1, 1).Value
  80. With fs
  81.     .LookIn = Chemin_Rech
  82.     .Filename = "*.ar"
  83.     .SearchSubFolders = True
  84.     If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
  85.         CreateObject("wscript.shell" ).popup "Il y a " & .FoundFiles.Count & " fichiers trouvés.", 2, "Banc :" & Adresse_Banc(N_Banc)
  86.         ' Début de la boucle pour passer en revue tout les fichiers AR trouvés
  87.         For i = 1 To .FoundFiles.Count
  88.             'Information Pour le status bar et la progression du travail
  89.             PourcentdAchevement = Fix(i / .FoundFiles.Count * 100)
  90.             Application.StatusBar = "Je mets en forme les données... j'en suis à " & PourcentdAchevement & " % (soit : " & i & " fichiers traités sur " & .FoundFiles.Count & " fichiers)"
  91. 'recherche le chemin du fichier puis extrait le repertoire racine
  92.             Chemin_En_Cours = Application.FileSearch.FoundFiles.Item(i)
  93.             file_name = Right(Chemin_En_Cours, Len(Chemin_En_Cours) - InStrRev(Chemin_En_Cours, "\" ))
  94. 'Copie du chemin et du fichier *.xls dans "fichiers_traites"
  95.             If Left(file_name, 1) = "~" Then GoTo Fin_if
  96.             ThisWorkbook.Sheets("Fichiers_traités" ).Range("C1" ).Value = file_name
  97. 'Teste si le fichier existe deja dans la base (a deja été traité)
  98.             If IsError(ThisWorkbook.Sheets("Fichiers_traités" ).Range("C4" )) Then
  99.                Fichier_Existe = False
  100.                Else
  101.                Fichier_Existe = True
  102.             End If
  103.      
  104.             If Fichier_Existe = True Then
  105. ' si le fichier a déjà été traité, la macro s'occupe de déplacer le PV, du dossier
  106. ' Retrofit S5 dans le dossier Fichiers Traités Retrofit S5 PDU68
  107. Dim fso As Object
  108. Dim remplace As Boolean
  109. Dim source As String
  110. Dim chemin2 As String
  111. Dim cible As String
  112.     Chemin = Worksheets("PARAMETRES" ).Range("E" & "52" ).Text
  113.     source = Chemin + "\" + file_name
  114.     chemin2 = Worksheets("PARAMETRES" ).Range("E" & "53" ).Text
  115.     cible = chemin2 + "\" + file_name
  116.     remplace = True
  117.     Set fso = CreateObject("Scripting.fileSystemObject" )
  118.     fso.copyFile source, cible, remplace
  119.     Kill source
  120.     End If
  121.          
  122.             If Fichier_Existe = False Then
  123.             Test_Si_Fichier_Ouvert = True 'test pour savoir si 1 seul fichier a été ouvert
  124.             Err = 0 ' mets la variable d'erreur à zéro
  125.             Workbooks.Open .FoundFiles.Item(i)
  126.             If Err = 1004 Then
  127.                 Err = 0
  128.                 Name_AR_En_Cours = fs.FoundFiles.Item(i)
  129.                 MyPos1 = InStrRev(Name_AR_En_Cours, "\" )
  130.                 ThisWorkbook.Activate
  131.                 Sheets("Fichiers_traités" ).Select
  132.                 ActiveCell = Right(Name_AR_En_Cours, Len(Name_AR_En_Cours) - MyPos1)
  133.                 ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Adresse_Banc(N_Banc) & Right(Name_AR_En_Cours, Len(Name_AR_En_Cours) - 3)
  134.                 ActiveCell.Offset(0, 1).Value = "Pb ouverture fichier"
  135.                 ActiveCell.Offset(1, 0).Activate
  136.                 CreateObject("wscript.shell" ).popup "Fichier : " & Right(Name_AR_En_Cours, Len(Name_AR_En_Cours) - MyPos1) & " non compatible", 2, "ERREUR FICHIER"
  137.                 GoTo Fin_if 'detectes si erreur à l'ouverture et envoi en fin de boucle fichier
  138.             End If
  139.             Name_AR_En_Cours = ActiveWorkbook.Name
  140.            
  141. 'Stocke le chemin du fichier et le nom du fichier
  142.             ThisWorkbook.Activate
  143.             Sheets("Fichiers_traités" ).Select
  144.             Range("A1" ).End(xlDown).Offset(1, 0).Activate
  145.             ActiveCell = Name_AR_En_Cours
  146.             ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Workbooks(Name_AR_En_Cours).Path & "\" & Workbooks(Name_AR_En_Cours).Name
  147.             ActiveCell.Offset(0, 1).Activate
  148. 'Reviens au debut de la ligne
  149.             ActiveCell.Offset(1, -1).Activate
  150.             'ActiveCell.End(xlToLeft).Activate
  151. 'passe sur le fichier mdv et stocke le nom du fichier (hypertexte)
  152.             Sheets("Résultat" ).Select
  153.             ActiveCell.Value = Name_AR_En_Cours
  154.             ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Workbooks(Name_AR_En_Cours).Path & "\" & Workbooks(Name_AR_En_Cours).Name
  155.             ActiveCell.Offset(0, 1).Activate
  156.             Sheets("extract" ).Select
  157.         Do
  158. 'Passe en revue la feuille extract sans deplacer la cellule active
  159.            
  160.             Carac_Rech_Old = ActiveCell.Offset(0, 1).Value
  161.             Carac_Rech_New = ActiveCell.Offset(0, 2).Value
  162.             Nb_Fois_Rech = ActiveCell.Offset(0, 3).Value
  163.             Rech_Avt = ActiveCell.Offset(0, 4).Value
  164.             Nb_car_rech_avt = ActiveCell.Offset(0, 5).Value
  165.             Rech_Après = ActiveCell.Offset(0, 6).Value
  166.             Nb_car_rech_Après = ActiveCell.Offset(0, 7).Value
  167.             Type_Result = ActiveCell.Offset(0, 8).Value
  168.             Carac_Rech = Carac_Rech_Old
  169.             Decalage_Ligne = ActiveCell.Offset(0, 11).Value
  170. 'ouvre l'autre fichier
  171.             Workbooks(Name_AR_En_Cours).Activate
  172.    
  173. 'Recherche la valeur de recherche dans le fichier AR
  174.             Cells.Find(What:=Carac_Rech, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
  175.             SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate


n°1589947
jpcheck
Pioupiou
Posté le 23-07-2007 à 09:56:59  profilanswer
 

ok ok,
 
 
il est possible de faire appel aux autres fichiers excel depuis un seul.  
 
bon alors a premiere vue, il faut juste que tu modifies ton thisworkbook ou bien que tu entres dans une boucle with pour faire un traitement non plus avec thisworkbook mais avec Workbooks()
 
ca te dit quelque chose ?

n°1589948
jackbauer9​72
Posté le 23-07-2007 à 10:02:31  profilanswer
 

Ca me dit quelque chose mais je ne vois pas trop la finalité.  
A quoi ça va me servir de faire un traitement avec Workbooks()?
 
Merci

n°1589949
jpcheck
Pioupiou
Posté le 23-07-2007 à 10:04:32  profilanswer
 

tu va pouvoir passer dans workbooks le path des fichiers que tu souhaites traiter. Thisworkbook te limite dans ton code à ton fichier dans lequel tourne la macro, c'est pour ca que je propose une méthode comme celle-ci :)

n°1590006
jackbauer9​72
Posté le 23-07-2007 à 11:38:55  profilanswer
 

J'ai compris ton idée cependant ayant un fichier excel avec une certaine mise en page, est ce que cela est faisable?
Et surtout, je souhaitais trouver un moyen afin que je puisse créer des fichiers susceptibles de subir des modifications. C'est à dire que je comptais créer un fichier original et à partir de celui ci créer tous les autres.  
 
Avec ta methode, si j'ai une modification du code, je serai obligé de faire les modif dans tous les autres fichiers manuellement, mais peut etre que je me trompes?

n°1590146
jpcheck
Pioupiou
Posté le 23-07-2007 à 14:00:03  profilanswer
 

pas nécessairement, sauf si tes calculs doivent se répercuter par la suite à chacun des fichiers finaux visés...

n°1590284
jackbauer9​72
Posté le 23-07-2007 à 15:49:45  profilanswer
 

De ce point de vue la, je pense que ça ira finalement mais en cas de modifications du code, comment répercuter cela sur tous les autres fichiers créés?
 
excuse moi d'insister comme ça.
 

n°1590290
jpcheck
Pioupiou
Posté le 23-07-2007 à 15:54:17  profilanswer
 

ben si ce sont simplement des formules dans des cellules, tu les imposes par macro depuis ton seul fichier, après si chaque document a sa propre finalité, faut gérer ca au cas par cas.


Aller à :
Ajouter une réponse
  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  Macro unique pour plusieurs fichiers excels

 

Sujets relatifs
Excel macro pour appliquer fonction sur une colonne[Batch] recuperer le log des fichiers copiés
Comment ouvrir tous les fichiers qui commence par les meme lettres?décomposer une adresse par macro sur excel
plusieurs valeurs dans un même champsPlusieurs flash dans une page html - probleme avec swfObject
Extraction de plusieurs requêtes SQL Server sous Word ou Excelfichiers .doc corrompus...
Gestion de plusieurs fichiers Excel. 
Plus de sujets relatifs à : Macro unique pour plusieurs fichiers excels


Copyright © 1997-2022 Hardware.fr SARL (Signaler un contenu illicite / Données personnelles) / Groupe LDLC / Shop HFR