jackbauer972 | Je suis pas certain que ça puisse t'aider beaucoup
Code :
- Sub Macro_Extract_data_Update()
- 'Lecture du login et du mot de passe dans les cellules G2 et G3
- 'ThisWorkbook.Activate
- 'Sheets("PARAMETRES" ).Select
- 'ActiveCell.Offset(1, 6).Value = Login
- 'ActiveCell.Offset(2, 6).Value = Password
- Ma_Reponse = MsgBox("Voulez-vous lancer l'extraction ?", vbYesNo)
- If Ma_Reponse = vbNo Then Exit Sub
- Dim NetR As NETRESOURCE
- NetR.dwScope = RESOURCE_GLOBALNET
- NetR.dwType = RESOURCETYPE_DISK
- NetR.dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
- NetR.dwUsage = RESOURCEUSAGE_CONNECTABLE
-
- 'Teste si les macros complementaires analysis toolpak sont installés (besoin pour calcul stat)
- Test_Si_Macro_Comp
- Sn_Différent = ""
- 'Initialisation de la feuile resultat_save
- ThisWorkbook.Activate
- Sheets("Résultat_Save" ).Visible = True
- Sheets("Résultat_Save" ).Select
- Range("A15" ).End(xlDown).Offset(1, 0).Activate
- Sheets("Résultat_Save" ).Visible = xlVeryHidden
- 'Détermination du nb de bancs et affectation des noms
- ThisWorkbook.Activate
- If Not IsEmpty(Range("Banc_N1" ).Offset(1, 0)) Then
- Nb_bancs = Range(Range("Banc_N1" ), Range("Banc_N1" ).End(xlDown)).Rows.Count
- Else: Nb_bancs = 1
- End If
- 'défini l'adresse des bancs.
- For k = 0 To Nb_bancs - 1
- Adresse_Banc(k + 1) = Range("Banc_N1" ).Offset(k, 0).Value & "\"
- Drive_Banc(k + 1) = ""
- Next k
- ListAllDrives 'teste si la connexion existe et remplit drive_banc(x)
- 'teste les 3 bancs les uns après les autres
- 'initialisation recherche
- ThisWorkbook.Activate
- Sheets("extract" ).Select
- Range("A2" ).Activate
- Sheets("Résultat" ).Select
- Range("A15" ).End(xlDown).Offset(1, 0).Activate
- On Error Resume Next
- Application.ScreenUpdating = False
- 'sauvegarde et mise à jour barre etat
- BarreEtatEnregistrée = Application.DisplayStatusBar
- Application.DisplayStatusBar = True
- Application.StatusBar = "Veuillez patienter quelques instants..."
- 'init var pour savoir si un fichier a été ajouté
- Test_Si_Fichier_Ouvert = False
- For N_Banc = 1 To Nb_bancs
-
- 'ouvre la session reseau
- Drive_Disconnect(N_Banc) = True
- NetR.lpLocalName = Fisrt_Letter_Free ' si non défini se connecte sans device
- NetR.lpRemoteName = Adresse_Banc(N_Banc) & "d$"
- Application.StatusBar = "Je me connecte au réseau : Banc numéro : " & Adresse_Banc(N_Banc)
-
- 'pour balayer de C28 à C38
- For NLigne = 28 To 38
- Password = Worksheets("PARAMETRES" ).Range("D" & CStr(NLigne)).Text
- Login = Worksheets("PARAMETRES" ).Range("C" & CStr(NLigne)).Text
- ErrInfo = WNetAddConnection2(NetR, Password, Login, CONNECT_UPDATE_PROFILE)
- Next
-
- If ErrInfo <> NO_ERROR Then
- CreateObject("wscript.shell" ).popup "ERROR: " & ErrInfo & " - Connection impossible sur le banc " & Adresse_Banc(N_Banc), 3, "Réseau non connecté"
- ErrInfo = ""
- GoTo Fin_Boucle_Banc
- End If
- Drive_Letter_Banc(N_Banc) = Fisrt_Letter_Free & "\"
- Else
- Application.StatusBar = "Je passe au Banc numéro : " & Adresse_Banc(N_Banc)
- Drive_Letter_Banc(N_Banc) = Drive_Banc(N_Banc)
- Drive_Disconnect(N_Banc) = False
- End If
- Set fs = Application.FileSearch
- ' definit le chemin de recherche des datas dans le rep \tmp (crée par chemin extraction)
- Chemin_Rech = Drive_Letter_Banc(N_Banc) & Range("Banc_N1" ).Offset(N_Banc - 1, 1).Value
- With fs
- .LookIn = Chemin_Rech
- .Filename = "*.ar"
- .SearchSubFolders = True
- If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
- CreateObject("wscript.shell" ).popup "Il y a " & .FoundFiles.Count & " fichiers trouvés.", 2, "Banc :" & Adresse_Banc(N_Banc)
- ' Début de la boucle pour passer en revue tout les fichiers AR trouvés
- For i = 1 To .FoundFiles.Count
- 'Information Pour le status bar et la progression du travail
- PourcentdAchevement = Fix(i / .FoundFiles.Count * 100)
- Application.StatusBar = "Je mets en forme les données... j'en suis à " & PourcentdAchevement & " % (soit : " & i & " fichiers traités sur " & .FoundFiles.Count & " fichiers)"
- 'recherche le chemin du fichier puis extrait le repertoire racine
- Chemin_En_Cours = Application.FileSearch.FoundFiles.Item(i)
- file_name = Right(Chemin_En_Cours, Len(Chemin_En_Cours) - InStrRev(Chemin_En_Cours, "\" ))
- 'Copie du chemin et du fichier *.xls dans "fichiers_traites"
- If Left(file_name, 1) = "~" Then GoTo Fin_if
- ThisWorkbook.Sheets("Fichiers_traités" ).Range("C1" ).Value = file_name
- 'Teste si le fichier existe deja dans la base (a deja été traité)
- If IsError(ThisWorkbook.Sheets("Fichiers_traités" ).Range("C4" )) Then
- Fichier_Existe = False
- Else
- Fichier_Existe = True
- End If
-
- If Fichier_Existe = True Then
- ' si le fichier a déjà été traité, la macro s'occupe de déplacer le PV, du dossier
- ' Retrofit S5 dans le dossier Fichiers Traités Retrofit S5 PDU68
- Dim fso As Object
- Dim remplace As Boolean
- Dim source As String
- Dim chemin2 As String
- Dim cible As String
- Chemin = Worksheets("PARAMETRES" ).Range("E" & "52" ).Text
- source = Chemin + "\" + file_name
- chemin2 = Worksheets("PARAMETRES" ).Range("E" & "53" ).Text
- cible = chemin2 + "\" + file_name
- remplace = True
- Set fso = CreateObject("Scripting.fileSystemObject" )
- fso.copyFile source, cible, remplace
- Kill source
- End If
-
- If Fichier_Existe = False Then
- Test_Si_Fichier_Ouvert = True 'test pour savoir si 1 seul fichier a été ouvert
- Err = 0 ' mets la variable d'erreur à zéro
- Workbooks.Open .FoundFiles.Item(i)
- If Err = 1004 Then
- Err = 0
- Name_AR_En_Cours = fs.FoundFiles.Item(i)
- MyPos1 = InStrRev(Name_AR_En_Cours, "\" )
- ThisWorkbook.Activate
- Sheets("Fichiers_traités" ).Select
- ActiveCell = Right(Name_AR_En_Cours, Len(Name_AR_En_Cours) - MyPos1)
- ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Adresse_Banc(N_Banc) & Right(Name_AR_En_Cours, Len(Name_AR_En_Cours) - 3)
- ActiveCell.Offset(0, 1).Value = "Pb ouverture fichier"
- ActiveCell.Offset(1, 0).Activate
- CreateObject("wscript.shell" ).popup "Fichier : " & Right(Name_AR_En_Cours, Len(Name_AR_En_Cours) - MyPos1) & " non compatible", 2, "ERREUR FICHIER"
- GoTo Fin_if 'detectes si erreur à l'ouverture et envoi en fin de boucle fichier
- End If
- Name_AR_En_Cours = ActiveWorkbook.Name
-
- 'Stocke le chemin du fichier et le nom du fichier
- ThisWorkbook.Activate
- Sheets("Fichiers_traités" ).Select
- Range("A1" ).End(xlDown).Offset(1, 0).Activate
- ActiveCell = Name_AR_En_Cours
- ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Workbooks(Name_AR_En_Cours).Path & "\" & Workbooks(Name_AR_En_Cours).Name
- ActiveCell.Offset(0, 1).Activate
- 'Reviens au debut de la ligne
- ActiveCell.Offset(1, -1).Activate
- 'ActiveCell.End(xlToLeft).Activate
- 'passe sur le fichier mdv et stocke le nom du fichier (hypertexte)
- Sheets("Résultat" ).Select
- ActiveCell.Value = Name_AR_En_Cours
- ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Workbooks(Name_AR_En_Cours).Path & "\" & Workbooks(Name_AR_En_Cours).Name
- ActiveCell.Offset(0, 1).Activate
- Sheets("extract" ).Select
- Do
- 'Passe en revue la feuille extract sans deplacer la cellule active
-
- Carac_Rech_Old = ActiveCell.Offset(0, 1).Value
- Carac_Rech_New = ActiveCell.Offset(0, 2).Value
- Nb_Fois_Rech = ActiveCell.Offset(0, 3).Value
- Rech_Avt = ActiveCell.Offset(0, 4).Value
- Nb_car_rech_avt = ActiveCell.Offset(0, 5).Value
- Rech_Après = ActiveCell.Offset(0, 6).Value
- Nb_car_rech_Après = ActiveCell.Offset(0, 7).Value
- Type_Result = ActiveCell.Offset(0, 8).Value
- Carac_Rech = Carac_Rech_Old
- Decalage_Ligne = ActiveCell.Offset(0, 11).Value
- 'ouvre l'autre fichier
- Workbooks(Name_AR_En_Cours).Activate
-
- 'Recherche la valeur de recherche dans le fichier AR
- Cells.Find(What:=Carac_Rech, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
- SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Activate
|
|