Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Traitement sur plusieurs fichiers (MAJ information) Excel VBA

hastaz

XLDnaute Nouveau
Bonjour le Forum;
Travaillant sur un traitement de DATA Je coince depuis un moment sur un point. J'ai créé un fichier comportant une nouvelle numérotation des contrats employés (colonne NewId). Je souhaiterai par conséquent mettre à jour Id contrats dans plusieurs fichiers appartenant au même dossier(35 fichiers au total) sachant qu'un employé peut avoir plusieurs contrats(1,2,3,....). Je viens solliciter votre aide afin d'automatiser la M A J des id contrat avec une VBA, en s'appuyant sur la clé Numéro Perso et Id contrat. Je souhaiterai qu'à chaque changement de numérotation de contrat (entre ld contrat et NewID) mettre le newId à la place de ID contrat.

Merci d'avance pour votre aide.
 

Pièces jointes

  • Fichier1.xlsx
    24.1 KB · Affichages: 8
  • Fichier2.xlsx
    29.8 KB · Affichages: 6
  • Mise à jours des fichiers selon renumerotation ID.xlsx
    53.5 KB · Affichages: 6
Solution
Bonjour hastaz, bonjour le forum,

VB: 
Sub ThauTheme()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TS As Variant 'déclare la variable TS (Tableau Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TD As Variant 'déclare la variable TD (Tableau Destination)
Dim I1 As Integer 'déclare la variable I1 (Incrément 1)
Dim I2 As Integer 'déclare la variable I2 (Incrément 2)

Application.ScreenUpdating = fasle 'masque les rafraîchissements d'écran
Set CS = ThisWorkbook 'définit le classeur source CS
CA = CS.Path &...
Trier par date Trier par votes

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour hastaz, bonjour le forum,

VB: 
Sub ThauTheme()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TS As Variant 'déclare la variable TS (Tableau Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TD As Variant 'déclare la variable TD (Tableau Destination)
Dim I1 As Integer 'déclare la variable I1 (Incrément 1)
Dim I2 As Integer 'déclare la variable I2 (Incrément 2)

Application.ScreenUpdating = fasle 'masque les rafraîchissements d'écran
Set CS = ThisWorkbook 'définit le classeur source CS
CA = CS.Path & "\" 'définit le chemin d'accès CA
Set OS = CS.Worksheets("Feuil1") 'définit l'onglet source OS
TS = OS.Range("A1").CurrentRegion 'définit le tableau source TS
F = Dir(CA & "*.xlsx") 'définit le premier fichier F ayant l'extension xlsx et CA comme chemin d'accès
Do 'execute
    If F <> CS.Name Then 'condition si F ne porte pas le nom du classeur source
        Set CD = Workbooks.Open(CA & F) 'définit le classeur destination CD en l'ouvrant
        Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
        TD = OD.Range("A1").CurrentRegion 'définit le tableau destination TD
    End If 'fin de la condition
    For I1 = 2 To UBound(TS, 1) 'boucle 1 : sur toutes les lignes I1 du tableau source TS (en partant de la seconde)
        If TS(I1, 3) <> TS(I1, 4) Then
            For I2 = 2 To UBound(TD, 1) 'boucle 2 : sur toutes les lignes I2 du tableau destination TD (en partant de la seconde)
                'condition : les matricules et les IDContrat correspondent
                If TS(I1, 1) = TD(I2, 1) And TS(I1, 3) = TD(I2, 3) Then
                    OD.Cells(I2, 3).Value = TS(I1, 4) 'recupère le NewId
                    OD.Cells(I2, 3).Interior.ColorIndex = 4 'colore la cellule modifiée
                End If 'fin de la condition
            Next I2 'prochaine ligne de la boucle 2
        End If
    Next I1 'prochaine ligne de la boucle 1
    CD.Close True 'ferme le classeur destination en enregistrant les modifications
    F = Dir 'définit le prochain fichier F ayant l'extension xlsx et CA comme chemin d'accès
Loop While F <> "" 'boucle tant qu'il existe de fichier F
Application.ScreenUpdating = fasle 'affiche les rafraîchissements d'écran
End Sub
 
Vote positif 1 Vote négatif
Solution

hastaz

XLDnaute Nouveau
job75 à dit:
Bonjour hastaz, Robert,

A quoi sert le Numero perso ? Je pense que cette donnée est inutile.

Robert ne s'en sert d'ailleurs pas.

A+
Cliquez pour agrandir...
Bonsoir job75,
c'est selon le numéro perso et l'ancien IDContrat que l'on peut savoir s'il y'a un écart de numérotation dans les autres fichiers et suite à cela on modifie le Idcontrat avec le new ID ( En quelques sorte je souhaiterai comparer numéro perso + ancienId contrat dans tout les fichiers si je trouve un écart du numérotation j'affecte le newId au contrat en question.
 
Vote positif 0 Vote négatif

hastaz

XLDnaute Nouveau
Je ne dois surtout pas prendre le matricule comme clé de comparaison car dans mes données, je peux avoir un numéro perso avec plusieurs matricules différents les uns des autres .
 
Vote positif 0 Vote négatif

hastaz

XLDnaute Nouveau
Bonsoir Robert,
je souhaiterai que l'on prenne le numéro perso comme clé car on ne peut se fier au matricule. Je ne l'ai pas mentionné précédemment. Je m'en excuse.
merci.
 
Vote positif 0 Vote négatif

hastaz

XLDnaute Nouveau
Il me semble qu’il s’est servi du matricule au lieu du numéro perso. Il est possible que je me trompe car je me perds un peu dans la lecture du code . Les résultats sont bons pour mon jeu de données. je pousserai les tests un peu plus avec les données entières.
 
Vote positif 0 Vote négatif

Robert

XLDnaute Barbatruc
Repose en paix
Bonjour le fil, bonjour le forum,

Avec un code Full Comment, changer n'aurait pas dû poser de problème...

Remplace la ligne : (Matricule)
VB: 
If TS(I1, 1) = TD(I2, 1) And TS(I1, 3) = TD(I2, 3) Then
par : (Numéro Perso)
VB: 
If TS(I1, 2) = TD(I2, 2) And TS(I1, 3) = TD(I2, 3) Then
 
Vote positif 0 Vote négatif

hastaz

XLDnaute Nouveau
Merci Bien Robert, c'est résolu.
Bonne journée.
 
Vote positif 0 Vote négatif

hastaz

XLDnaute Nouveau
Bonjour Robert, le Forum,
J'ai exécuté la macro sur un autre jeu de donnée et je remarque un déphasage de numérotation de contrats. Pourriez vous m'aider à résoudre le problème s'il vous plait.
merci d'avance.
 

Pièces jointes

  • FICHIER1.xlsx
    10.3 KB · Affichages: 6
  • FICHIER2.xlsx
    10.3 KB · Affichages: 4
  • FICHIERMACRO.xlsm
    18.2 KB · Affichages: 3
Vote positif 0 Vote négatif

job75

XLDnaute Barbatruc
Bonjour hastaz, Robert, le forum,
hastaz à dit:
je remarque un déphasage de numérotation de contrats.
Cliquez pour agrandir...
Vous vous trompez hastaz il n'y a pas d'erreur dans les résultats de la macro de Robert.

Cela dit puisque je repasse par ici voici une solution plus rapide qui utilise le Dictionary :
VB: 
Sub NewID()
Dim chemin$, fichier$, d As Object, tablo, i&, x$
chemin = ThisWorkbook.Path & "\" 'dossier à adapter éventuellement
fichier = Dir(chemin & "*.xlsx") '1er fichier .xlsx du dossier
'---liste concaténée sans doublon---
Set d = CreateObject("Scripting.Dictionary")
tablo = [A1].CurrentRegion.Resize(, 4) 'matrice, plus rapide
For i = 2 To UBound(tablo)
    d(tablo(i, 2) & Chr(1) & tablo(i, 3)) = tablo(i, 4) 'mémorise le dernier NewId trouvé
Next i
'---traitement des fichiers---
Application.ScreenUpdating = False
While fichier <> ""
    With Workbooks.Open(chemin & fichier).Sheets(1) 'ouvre le fichier
        tablo = .Cells(1).CurrentRegion.Resize(, 3) 'matrice, plus rapide
        For i = 2 To UBound(tablo)
            x = tablo(i, 2) & Chr(1) & tablo(i, 3)
            If d.exists(x) Then tablo(i, 3) = d(x) 'NewID quand il existe
        Next i
        .Cells(1, 3).Resize(UBound(tablo)) = Application.Index(tablo, , 3) 'restitue la 3ème colonne
        .Parent.Close True 'enregistre et ferme le fichier
    End With
    fichier = Dir 'fichier suivant du dossier
Wend
End Sub
Les résultats sont les mêmes que ceux de la macro de Robert.

A+
 

Pièces jointes

  • FICHIERMACRO(1).xlsm
    19.6 KB · Affichages: 3
  • FICHIER1.xlsx
    10.6 KB · Affichages: 3
  • FICHIER2.xlsx
    10.5 KB · Affichages: 2
Vote positif 0 Vote négatif

hastaz

XLDnaute Nouveau
Bonsoir le fil,
Je reviens vers vous solliciter votre aide à propos d'une erreur rencontrée lors de l'exécution. J'obtiens le message suivant: erreur d'automation. Je voulais affecter le code de Robert (qui d'ailleurs, autant pour moi, fonctionne très bien. Le déphasage que j'ai rencontré lors des tests est dû aux fichiers d'extraction qui n'étaient pas conforme) à un bouton, j'ai par conséquent apporté quelques modifications mais j'ai certainement fais erreur quelques part. Pourriez vous m'apporter votre aide s'il vous plaît.
VB: 
Sub MAJ()
Dim fichier, NomFichier
fichier = Application.GetOpenFilename("Fichiers Microsoft Office Excel, *.xlsx")
If fichier = False Then Exit Sub
If fichier Like "*\" & ThisWorkbook.Name Then MsgBox "Ouverture non autorisée.": Exit Sub
On Error Resume Next
Workbooks.Open fichier
On Error GoTo 0
NomFichier = Dir(fichier)
Workbooks(NomFichier).Activate

Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim TS As Variant 'déclare la variable TS (Tableau Source)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim TD As Variant 'déclare la variable TD (Tableau Destination)
Dim I1 As Integer 'déclare la variable I1 (Incrément 1)
Dim I2 As Integer 'déclare la variable I2 (Incrément 2)

Application.ScreenUpdating = fasle 'masque les rafraîchissements d'écran
Set CS = ActiveWorkbook 'définit le classeur source CS
CA = CS.Path & "\" 'définit le chemin d'accès CA
MsgBox CA
Set OS = CS.Worksheets(1) 'définit l'onglet source OS
TS = OS.Range("C1").CurrentRegion 'définit le tableau source TS
F = Dir(CA & "*.xlsx") 'définit le premier fichier F ayant l'extension xlsx et CA comme chemin d'accès
Do 'execute
    If F <> CS.Name Then 'condition si F ne porte pas le nom du classeur source
        Set CD = Workbooks.Open(CA & F) 'définit le classeur destination CD en l'ouvrant
        Set OD = CD.Worksheets(1) 'définit l'onglet destination OD
        TD = OD.Range("C1").CurrentRegion 'définit le tableau destination TD
    End If 'fin de la condition
    For I1 = 2 To UBound(TS, 1) 'boucle 1 : sur toutes les lignes I1 du tableau source TS (en partant de la seconde)
        If TS(I1, 4) <> TS(I1, 5) Then
            For I2 = 2 To UBound(TD, 1) 'boucle 2 : sur toutes les lignes I2 du tableau destination TD (en partant de la seconde)
                'condition : les matricules et les IDContrat correspondent
                If TS(I1, 3) = TD(I2, 3) And TS(I1, 4) = TD(I2, 4) Then
                    OD.Cells(I2, 4).Value = TS(I1, 5) 'recupère le NewId
                    OD.Cells(I2, 3).Interior.ColorIndex = 4 'colore la cellule modifiée
                End If 'fin de la condition
            Next I2 'prochaine ligne de la boucle 2
        End If
    Next I1 'prochaine ligne de la boucle 1
    CD.Close True 'ferme le classeur destination en enregistrant les modifications
    F = Dir 'définit le prochain fichier F ayant l'extension xlsx et CA comme chemin d'accès
Loop While F <> "" 'boucle tant qu'il existe de fichier F
Application.ScreenUpdating = fasle 'affiche les rafraîchissements d'écran
End Sub
Je vous remercie d'avance.
Ps: L'erreur d'automation est au niveau de CD.Close
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

H
  • Question
Autres mise a jour automatique feuille excel vba
Réponses
2
Affichages
531
HANN
H
L
  • Question
Microsoft 365 Mise à jour d'une Base ACCESS depuis Excel office365
Réponses
6
Affichages
862
Hasco
G
  • Question
XL 2010 VBA -Transférer les données de plusieurs fichiers excel dans un seul fichier excel
Réponses
1
Affichages
1 K
grleclercqauchan.com
G
P
  • Question
XL 2016 Mise en place d'une étude hebdomadaire des remarques 5S - Bascule d'information entre 3 fichiers
Réponses
10
Affichages
1 K
gbinforme
G
A
  • Question
Microsoft 365 Mise à jour d'un tableau Excel en VBA à partir d'un autre classeur
Réponses
3
Affichages
1 K
AlexiaC
A
  • Question
XL 2019 Mise à jour automatique à distance des macro VBA dans un fichier sur un autre ordinateur
Réponses
3
Affichages
3 K
TooFatBoy
D
  • Question
XL 2010 Création et mise à jour d'un TCD tableau croisé dynamique avec macro VBA
Réponses
1
Affichages
2 K
chris
  • Question
Microsoft 365 Mettre à jour un code VBA
Réponses
1
Affichages
1 K
patricktoulon
C
  • Question
XL 2010 Créer une base de données à partir de plusieurs fichiers excel dans un même dossier
Réponses
7
Affichages
4 K
Yaloo
Y
C
  • Question
XL 2016 Mise à jour données possible seulement en ouvrant fichier lien
Réponses
0
Affichages
669
Claggan
C
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…