modifier une feuille en fonction d'un autre classeur, en comparant et ajoutant

superbog

superbog

XLDnaute Occasionnel
Bonsoir,

Voilà je travaille dans un classeur global et je dois mettre à jour la feuille ADH à partir d'un ficher extérieur qui se nomme ADH2.xlsx (j'ai joint les fichiers exemples).

ADH2 est rempli par une tierce personne qui tient à jour les coordonnées des adhérents et intègre les nouveaux. Je souhaite les intégrer à mon fichier global dans la feuille ADH.

Il s'agit d'une liste d'adhérents, je souhaite que les modifications soient automatiques de sorte que les nouveautés d'ADH2 viennent corriger ADH.

J'ai essayé de bidouiller ca mais... help :p

Code: 
Sub A8TESTER8compare_fichiers()
Dim dL1#, dl2#, i#, j#, k#
Dim tablo1, tablo2
Dim ws As Worksheet, différence As Boolean

Dim sh1 As Worksheet, sh2 As Worksheet

Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier est ouvert
Workbooks.Open "C:\ADH.xlsx" 'chemin à adapter
Set sh1 = Workbooks("ADH2.xlsx").Sheets("ADH")
Set sh2 = Workbooks("BB1.xlsx").Sheets("ADH")



    dL1 = sh1.Range("B2000").End(xlUp).Row
    For i = 2 To dL1
        On Error Resume Next
        On Error GoTo 0
              tablo1 = sh1.Range("A" & i & ":O" & i).Value
              
         dl2 = sh2.Range("B2000").End(xlUp).Row
         
    For k = 2 To dl2
        On Error Resume Next
        On Error GoTo 0
        
                tablo2 = sh2.Range("A" & k & ":O" & k).Value
          
                    If sh1.Range("A" & i & ":B" & i).Value = sh2.Range("A" & k & ":B" & k).Value Then
                
                For j = 1 To UBound(tablo1, 2)
                    If tablo1(1, j) <> tablo2(1, j) Then différence = True
                        Exit For
                        If difference Then sh2.Range("A" & i & ":O" & i) = tablo1
                Next k
            
                    
                End If
            End With
        End If
    Next i
End With
End Sub

merci d'avance
 

Pièces jointes

  • ADH2.xlsx
    9.7 KB · Affichages: 54
  • ADH.xlsx
    9.9 KB · Affichages: 35
Trier par date Trier par votes
superbog

superbog

XLDnaute Occasionnel
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : modifier une feuille en fonction d'un autre classeur, en comparant et ajoutant

Bonsoir superbog,

Depuis le temps...

Placez dans le ThisWorkbook du classeur ADH2 :

Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim nomfich$, chemin$, wb As Workbook, ferme As Boolean
nomfich = "ADH" 'nom du classeur de destination, à adapter
chemin = ThisWorkbook.Path & "\" 'chemin à adapter
On Error Resume Next
Set wb = Workbooks(nomfich)
nomfich = Dir(chemin & nomfich & ".xls*")
If wb Is Nothing Then Application.ScreenUpdating = False: _
  Set wb = Workbooks.Open(chemin & nomfich): ferme = True
Me.Sheets(1).Cells.Copy wb.Sheets(1).[A1]
Me.Sheets(1).[A1].Copy wb.Sheets(1).[A1] 'vide le presse-papiers
wb.Save
If ferme Then wb.Close
End Sub
Et enregistrez-le en .xlsm.

Bonne fin de soirée.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : modifier une feuille en fonction d'un autre classeur, en comparant et ajoutant

Bonjour,

Il est très possible que le fichier de destination soit déjà ouvert par un autre utilisateur.

Alors voyez ceci (je ne peux pas vraiment tester) :

Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim nomfich$, chemin$, wb As Workbook
chemin = ThisWorkbook.Path & "\" 'chemin à adapter
nomfich = "ADH.xlsx" 'nom du classeur à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Workbooks.Open chemin & nomfich
With ActiveWorkbook
  If .Name = Me.Name Or .ReadOnly Then
    Cancel = True
    If .ReadOnly Then .Close False
    Application.ScreenUpdating = True
    MsgBox "Enregistrement impossible, voyez avec l'Administrateur..."
  Else
    Me.Sheets(1).Cells.Copy .Sheets(1).[A1]
    Me.Sheets(1).[A1].Copy .Sheets(1).[A1] 'vide le presse-papiers
    .Close True
  End If
End With
End Sub
A+
 
Vote positif 0 Vote négatif
superbog

superbog

XLDnaute Occasionnel
Re : modifier une feuille en fonction d'un autre classeur, en comparant et ajoutant

merci JOB 75, c'est déjà génial et si simple quand on te lit... :eek:

serait il possible d'affiner la chose d'une part en limitant les modifications aux colonnes A à Q

d'autre part (plus compliqué je pense), une fois que les modif sont faites, elles doivent se recopier automatiquement. En effet dans le classeur ADH il y a une feuille globale ADH (celle que tu m'as permis de mettre à jour) et ensuite une feuille correspondant à chaque adhérent.
C'est assez simple car les infos contenues dans les colonnes A à Q se retrouvent totalement dans la ligne 2 (colonne A à Q) de chaque feuille adhérent.

J'ai en principe une macro (ci dessous) qui fonctionne parfaitement quand on change manuellement une cellule, or là avec ton système c'est global donc ca ne fonctionne pas.

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim DerLig As Long, Feuille As String, Ligne As Long
 Dim test As String
 DerLig = Range("A" & Rows.Count).End(xlUp).Row
 If Not Intersect(Target, Range("A2:R" & DerLig)) Is Nothing Then
    Application.ScreenUpdating = False 'désactive le rafraichissement écran
    test = IsError(Evaluate("= " & Range("A" & Target.Row) & "!A1")) ' test si la feuille existe
    If test Then
        MsgBox "La feuille n'existe pas"
    Else
        Feuille = Range("A" & Target.Row) 'Nom de la feuille
        Ligne = Target.Row              'NÁ de ligne
        Sheets("clients").Range("A" & Ligne & ":R" & Ligne).Copy Worksheets(Feuille).Range("A2")
        
    End If
    Application.ScreenUpdating = True 'affiche les changements à l'écran
 End If
End Sub
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : modifier une feuille en fonction d'un autre classeur, en comparant et ajoutant

Re,

Si je comprends bien le fichier de destination est un fichier .xlsm et pour récupérer les colonnes A:Q :

Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim nomfich$, chemin$
chemin = ThisWorkbook.Path & "\" 'chemin à adapter
nomfich = "ADH.xlsm" 'nom du classeur à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Workbooks.Open chemin & nomfich
With ActiveWorkbook
  If .Name = Me.Name Or .ReadOnly Then
    Cancel = True
    If .ReadOnly Then .Close False
    Application.ScreenUpdating = True
    MsgBox "Enregistrement impossible, voyez avec l'Administrateur..."
  Else
    Me.Sheets(1).[A:Q].Copy .Sheets(1).[A1]
    Me.Sheets(1).[A1].Copy .Sheets(1).[A1] 'vide le presse-papiers
    .Close True
  End If
End With
End Sub
Pour les autres feuilles c'est un autre problème, votre macro est à revoir, ouvrez un autre fil.

Edit : il faudra expliquer pourquoi vous ne copiez qu'une seule ligne (2) dans les autres feuilles car a priori c'est de peu d'intérêt...

A+
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : modifier une feuille en fonction d'un autre classeur, en comparant et ajoutant

Bonjour superbog, le forum,

Bon allez, ceci vous évitera d'ouvrir une nouvelle discussion :

Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim nomfich$, chemin$, d As Object, i&, nf$, df As Object
Dim a, w As Worksheet, j&, x As Variant, y As Variant
nomfich = "ADH.xlsm" 'nom du classeur à adapter
chemin = ThisWorkbook.Path & "\" 'chemin à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False 'désactive les évènements, au cas où...
On Error Resume Next
Workbooks.Open chemin & nomfich
With ActiveWorkbook
  If .Name = Me.Name Or .ReadOnly Then
    Cancel = True
    If .ReadOnly Then .Close False
    Application.ScreenUpdating = True
    MsgBox "Enregistrement impossible, voyez avec l'Administrateur..."
  Else
    Me.Sheets(1).[A:Q].Copy .Sheets(1).[A1]
    Me.Sheets(1).[A1].Copy .Sheets(1).[A1] 'vide le presse-papiers
    '---liste des valeurs en colonne 1 sans doublon---
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To .Sheets(1).UsedRange.Rows.Count
      nf = .Sheets(1).Cells(i, 1)
      If nf <> "" Then d(nf) = i 'repérage de la ligne
    Next
    '---ligne 2 des feuilles ou suppression---
    Set df = CreateObject("Scripting.Dictionary")
    For i = .Sheets.Count To 2 Step -1
      nf = .Sheets(i).Name
      If d.exists(nf) Then
        .Sheets(1).Cells(d(nf), 1).Resize(, 17).Copy .Sheets(i).[A2]
        df(nf) = ""
      Else
        .Sheets(i).Delete
      End If
    Next
    '---création des feuilles manquantes---
    If d.Count Then
      a = d.keys
      For i = 0 To UBound(a)
        If Not df.exists(a(i)) Then
          Set w = .Sheets.Add(After:=.Sheets(1))
          w.Name = a(i)
          .Sheets(1).Cells(1).Resize(, 17).Copy w.[A1]
          .Sheets(1).Cells(d(a(i)), 1).Resize(, 17).Copy w.[A2]
          w.Columns.AutoFit 'ajustement largeur
        End If
      Next
    End If
    '---classement des onglets---
    For i = 2 To .Sheets.Count 'on ne touche pas au 1er onglet
      x = .Sheets(i).Name: If IsNumeric(x) Then x = CDbl(x)
      For j = i + 1 To .Sheets.Count
        y = .Sheets(j).Name: If IsNumeric(y) Then y = CDbl(y)
        If y < x Then .Sheets(j).Move Before:=.Sheets(i)
    Next j, i
    .Sheets(1).Activate
    '---enregistrement et fermeture---
    .Close True
  End If
End With
Application.EnableEvents = True 'réactive les évènements
End Sub
Fichiers joints pour tester, j'ai formaté correctement les colonnes du code postal et du téléphone.

Bonne journée.
 

Pièces jointes

  • ADH2(1).xlsm
    20.7 KB · Affichages: 61
  • ADH.xlsm
    8 KB · Affichages: 51
Vote positif 0 Vote négatif
superbog

superbog

XLDnaute Occasionnel
Re : modifier une feuille en fonction d'un autre classeur, en comparant et ajoutant

c'est gentil, merci
un petit souci, le formatage code postal et tel pose pb car j'ai des adhérents étrangers et donc que ce soit le code postal ou le tel c'est compliqué
ce formatage est il nécessaire pour la macro?
et subsidiairement, quel intérêt (si ce n'est le côté systématique) de le mettre dans thisworkbook. Puis je l'utiliser comme une macro standard?


job75 à dit:
Bonjour superbog, le forum,

Bon allez, ceci vous évitera d'ouvrir une nouvelle discussion :

Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim nomfich$, chemin$, d As Object, i&, nf$, df As Object
Dim a, w As Worksheet, j&, x As Variant, y As Variant
nomfich = "ADH.xlsm" 'nom du classeur à adapter
chemin = ThisWorkbook.Path & "\" 'chemin à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False 'désactive les évènements, au cas où...
On Error Resume Next
Workbooks.Open chemin & nomfich
With ActiveWorkbook
  If .Name = Me.Name Or .ReadOnly Then
    Cancel = True
    If .ReadOnly Then .Close False
    Application.ScreenUpdating = True
    MsgBox "Enregistrement impossible, voyez avec l'Administrateur..."
  Else
    Me.Sheets(1).[A:Q].Copy .Sheets(1).[A1]
    Me.Sheets(1).[A1].Copy .Sheets(1).[A1] 'vide le presse-papiers
    '---liste des valeurs en colonne 1 sans doublon---
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To .Sheets(1).UsedRange.Rows.Count
      nf = .Sheets(1).Cells(i, 1)
      If nf <> "" Then d(nf) = i 'repérage de la ligne
    Next
    '---ligne 2 des feuilles ou suppression---
    Set df = CreateObject("Scripting.Dictionary")
    For i = .Sheets.Count To 2 Step -1
      nf = .Sheets(i).Name
      If d.exists(nf) Then
        .Sheets(1).Cells(d(nf), 1).Resize(, 17).Copy .Sheets(i).[A2]
        df(nf) = ""
      Else
        .Sheets(i).Delete
      End If
    Next
    '---création des feuilles manquantes---
    If d.Count Then
      a = d.keys
      For i = 0 To UBound(a)
        If Not df.exists(a(i)) Then
          Set w = .Sheets.Add(After:=.Sheets(1))
          w.Name = a(i)
          .Sheets(1).Cells(1).Resize(, 17).Copy w.[A1]
          .Sheets(1).Cells(d(a(i)), 1).Resize(, 17).Copy w.[A2]
          w.Columns.AutoFit 'ajustement largeur
        End If
      Next
    End If
    '---classement des onglets---
    For i = 2 To .Sheets.Count 'on ne touche pas au 1er onglet
      x = .Sheets(i).Name: If IsNumeric(x) Then x = CDbl(x)
      For j = i + 1 To .Sheets.Count
        y = .Sheets(j).Name: If IsNumeric(y) Then y = CDbl(y)
        If y < x Then .Sheets(j).Move Before:=.Sheets(i)
    Next j, i
    .Sheets(1).Activate
    '---enregistrement et fermeture---
    .Close True
  End If
End With
Application.EnableEvents = True 'réactive les évènements
End Sub
Fichiers joints pour tester, j'ai formaté correctement les colonnes du code postal et du téléphone.

Bonne journée.
Cliquez pour agrandir...
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : modifier une feuille en fonction d'un autre classeur, en comparant et ajoutant

Re,

Il est essentiel que le code soit exécuté quand on enregistre le fichier source.

Donc avec l'évènement BeforeSave.

Si le fichier de destination est introuvable ou est en lecture seule l'enregistrement n'a pas lieu.

Pour le formatage de la feuille source faites ce que vous voulez.

A+
 
Vote positif 0 Vote négatif
superbog

superbog

XLDnaute Occasionnel
Re : modifier une feuille en fonction d'un autre classeur, en comparant et ajoutant

Merci beaucoup job75, tu es vraiment un dieu d'excel, je suis baba chaque fois.
quand je pense à l'usine à gaz que j'ai montée, je frémis.
 
Dernière édition:
Vote positif 0 Vote négatif
superbog

superbog

XLDnaute Occasionnel
Re : modifier une feuille en fonction d'un autre classeur, en comparant et ajoutant

job75 à dit:
Re,

Si je comprends bien le fichier de destination est un fichier .xlsm et pour récupérer les colonnes A:Q :

Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim nomfich$, chemin$
chemin = ThisWorkbook.Path & "\" 'chemin à adapter
nomfich = "ADH.xlsm" 'nom du classeur à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Workbooks.Open chemin & nomfich
With ActiveWorkbook
  If .Name = Me.Name Or .ReadOnly Then
    Cancel = True
    If .ReadOnly Then .Close False
    Application.ScreenUpdating = True
    MsgBox "Enregistrement impossible, voyez avec l'Administrateur..."
  Else
    Me.Sheets(1).[A:Q].Copy .Sheets(1).[A1]
    Me.Sheets(1).[A1].Copy .Sheets(1).[A1] 'vide le presse-papiers
    .Close True
  End If
End With
End Sub
Pour les autres feuilles c'est un autre problème, votre macro est à revoir, ouvrez un autre fil.

Edit : il faudra expliquer pourquoi vous ne copiez qu'une seule ligne (2) dans les autres feuilles car a priori c'est de peu d'intérêt...

A+
Cliquez pour agrandir...

pour vous répondre, c'est parce que chaque feuille concerne une personne et que d'autres feuilles y font référence de sorte que j'ai besoin que la feuille de chaque personne soit toujours à jour.
je l'ai dit, j'ai monté un truc assez compliqué qui fait 9 Mo

en fait il y a, dans le même classeur
* des feuilles générales (liste adhérent, temps passés tous adhérents confondus pour telle activité, temps passé tous adhérents confondus pour telle autre activité, forfaits, frais, ...). ces feuilles sont remplies grâce à des macros qui vont chercher les infos dans des classeurs sources remplis par d'autres personnes, dans un autre répertoire
* des feuilles adhérent, une par personne, qui regroupent toutes les infos des feuilles générales mais adhérent par adhérent. ces feuilles sont remplies par des macros qui vont chercher l'info dans les feuilles générales
* des feuilles récapitulatives (relevé global par mois pour un adhérent spécifique (avec des formules et un peu de macro), édition de factures (par macro), envoi de demande de paiement par gmail (en macro)...

si vous avez une idée pour simplifier je suis preneur
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : modifier une feuille en fonction d'un autre classeur, en comparant et ajoutant

Bonjour superbog, le forum,

Deux compléments pour ce fichier (2) :

- dans le classeur ADH.xlsm 4 feuilles non-adhérents (toujours les 1ers onglets) avec la variable nglobal = 4

- le classement des onglets ne se fait que si des feuilles sont créées, cela diminue la durée d'exécution.

Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim dur#, nomfich$, chemin$, nglobal%, d As Object, i&, nf$, df As Object
Dim a, classement As Boolean, w As Worksheet, j&, x As Variant, y As Variant
dur = Timer
nomfich = "ADH.xlsm" 'nom du classeur de destination à adapter
chemin = ThisWorkbook.Path & "\" 'chemin à adapter
nglobal = 4 'nombre de feuilles non adhérent du fichier de destination
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False 'désactive les évènements, au cas où...
On Error Resume Next
Workbooks.Open chemin & nomfich
With ActiveWorkbook
  If .Name = Me.Name Or .ReadOnly Then
    Cancel = True
    If .ReadOnly Then .Close False
    Application.ScreenUpdating = True
    MsgBox "Enregistrement impossible, voyez avec l'Administrateur..."
  Else
    Me.Sheets(1).[A:Q].Copy .Sheets(1).[A1]
    Me.Sheets(1).[A1].Copy .Sheets(1).[A1] 'vide le presse-papiers
    '---liste des valeurs en colonne 1 sans doublon---
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To .Sheets(1).UsedRange.Rows.Count
      nf = .Sheets(1).Cells(i, 1)
      If nf <> "" Then d(nf) = i 'repérage de la ligne
    Next
    '---ligne 2 des feuilles ou suppression---
    Set df = CreateObject("Scripting.Dictionary")
    For i = .Sheets.Count To nglobal + 1 Step -1
      nf = .Sheets(i).Name
      If d.exists(nf) Then
        .Sheets(1).Cells(d(nf), 1).Resize(, 17).Copy .Sheets(i).[A2]
        df(nf) = ""
      Else
        .Sheets(i).Delete
      End If
    Next
    '---création des feuilles manquantes---
    If d.Count Then
      a = d.keys
      For i = 0 To UBound(a)
        If Not df.exists(a(i)) Then
          classement = True
          Set w = .Sheets.Add(After:=.Sheets(.Sheets.Count))
          w.Name = a(i)
          .Sheets(1).Cells(1).Resize(, 17).Copy w.[A1]
          .Sheets(1).Cells(d(a(i)), 1).Resize(, 17).Copy w.[A2]
          w.Columns.AutoFit 'ajustement largeur
        End If
      Next
    End If
    '---classement des onglets---
    If classement Then
      For i = nglobal + 1 To .Sheets.Count 'on ne touche pas aux nglobal 1ers onglets
        x = .Sheets(i).Name: If IsNumeric(x) Then x = CDbl(x)
        For j = i + 1 To .Sheets.Count
          y = .Sheets(j).Name: If IsNumeric(y) Then y = CDbl(y)
          If y < x Then .Sheets(j).Move Before:=.Sheets(i)
      Next j, i
    End If
    .Sheets(1).Activate
    '---enregistrement et fermeture---
    .Close True
  End If
End With
Application.EnableEvents = True 'réactive les évènements
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - dur, "0.00 \s")
End Sub
Pour tester j'ai mis 1000 dossiers/adhérents, évidemment la création des 1000 feuilles prend du temps.

A+
 

Pièces jointes

  • ADH2(2).xlsm
    29.9 KB · Affichages: 41
  • ADH.xlsm
    9.3 KB · Affichages: 38
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

T
  • Question
Microsoft 365 probleme passage paramètre dans une fonction
Réponses
8
Affichages
273
Phil69970
Phil69970
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
215
Compte Supprimé 979
C
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
155
GClaire
G
Regueiro
  • Question
Microsoft 365 VBA Transpose
Réponses
11
Affichages
297
sylvanu
sylvanu
S
  • Résolu(e)
XL 2016 problème de filtre dans listbox
2 3 4
Réponses
51
Affichages
1 K
saidoush
S
S
  • Question
XL 2016 VBA EXCEL
Réponses
2
Affichages
325
simon-baril01
S
D
  • Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
290
Dranreb
Dranreb
S
  • Question
XL 2013 recherche intuitif semi automatique dans Combobox (trié et avec valeur unique) inseré en UserForm VBA
2
Réponses
18
Affichages
436
Sghaier Chafaa
S
halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
548
halecs93
halecs93
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
470
Phil69970
Phil69970

Membres actuellement en ligne

14 membres et 125 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 249
Messages
2 086 598
Membres
103 253
dernier inscrit
alscanv974