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

superbog · 30 Janvier 2016

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

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

superbog · 28 Juin 2016

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

Merci à toi. Pour simplifier, sache que les feuilles adhérents portent chacune le numéro de l'adhérent comme nom alors que les feuilles non adhérents portent un nom donc il suffit de faire un classement de toutes les feuilles numériques pour que les feuilles adhérents soient classées

Je vais essayer ta super macro et je reviens très vite, merci vraiment de ton aide car les macros que j'ai fait fonctionnent mais certaines font régulièrement planter excel notamment celle de l'envoi par gmail.

job75 à dit:

Bonjour superbog, le forum,

Deux compléments dans ce fichier (2) :

- j'ai ajouté des feuilles non-adhérents (toujours les 1ers onglets) et 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+

job75 · 28 Juin 2016

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

Re,

Avec cette version (3) la colonne O (archivage) est utilisée pour le repérage des modifications (lettre A).

Dans le code de la feuille "ADH" :

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range
Set P = Intersect(Target, Me.UsedRange.Resize(, 17))
Application.EnableEvents = False
On Error Resume Next
Intersect(P.EntireRow, Range("O2:O" & Rows.Count)) = "A" 'repère
Intersect([A:A].SpecialCells(xlCellTypeBlanks).EntireRow, [O:O]) = ""
Application.EnableEvents = True
End Sub

Et dans ThisWorkbook voyez les 2 lignes de code ajoutées à ce sujet.

Avec la version (2) la durée d'exécution est chez moi de 6 secondes.

Avec cette version (3) la durée d'exécution se réduit à 2,8 secondes.

A+

job75 · 28 Juin 2016

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

Re,

Vous aurez peut-être constaté comme moi un phénomène très curieux avec le fichier ADH.xlsm de 1000 feuilles.

Quand on enregistre le fichier source normalement tout se passe bien, avec les durées d'exécution que j'ai indiquées.

Mais il suffit d'aller dans VBA (sans même toucher aux codes) pour qu'il y ait un problème.

La durée d'exécution dépasse alors les 2 minutes.

Et j'ai pu vérifier que c'est dû uniquement à l'instruction .Close True : l'enregistrement du fichier de destination prend un temps fou, alors que ce fichier de 1 Mo s'enregistre normalement en 1 seconde.

Si l'on ferme le fichier source et qu'on le rouvre tout rendre dans l'ordre.

Je ne m'explique pas du tout ce phénomène, que je découvre pour la 1ère fois.

Est-ce dû à ma version Excel (2013 sur Win10) ?

Bonne soirée.

job75 · 28 Juin 2016

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

Re,

Je découvre encore.

Après avoir été dans VBA, si on ferme la fenêtre VBA le phénomène évoqué ne se produit pas.

Donc VBA ne doit pas être ouvert pendant l'exécution du code.

Bonne fin de soirée.

job75 · 29 Juin 2016

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

Bonjour superbog, le forum,

Il n'y a donc plus aucun souci en ajoutant en début de code :

Code:

Application.VBE.MainWindow.Visible = False 'ferme la fenêtre VBA

Mais il faut avoir coché l'option :

Accès approuvé au modèle d'objet du projet VBA

Onglet DÉVELOPPEUR => Sécurité des macros => Paramètres des macros

Version (4).

Bonne journée.

superbog · 29 Juin 2016

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

ouahouu tu trouves les problèmes et les règles alors que j'en suis encore à trouver normal que cela mette un temps fou, je suis habituée avec mes macros bidouillées

une question cependant, je ne comprends pas très bien quelles sont les conséquences précises de prendre la colonne archivage pour le repérage

En effet cette colonne me sert (à noter ce qui est archivé au fur et à mesure)... je ne voudrais pas faire d'erreur

job75 · 29 Juin 2016

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

Re,

Avec la colonne O on gagne 3 secondes sur la durée d'exécution, mais vous n'êtes pas obligée d'utiliser la version (3).

Utilisez la version (2).

A+

superbog · 6 Janvier 2017

Bonsoir à tous et super bonne année

Après divers essais je m'aperçois que ce système, qui fonctionne, n'est pas vraiment satisfaisant car au final l'ordi de l'utilisateur du classeur adh n'a pas accès au repertoire ou se trouve le classeur adh2

donc il faudrait que je puisse faire fonctionner la macro à partir du classeur adh2 afin que les nouveautés entrées dans le classeur adh onglet adh se copient et s'incrémente sur les différentes feuilles existants.
pas besoin de créer la nouvelle feuille si elle n'existe pas, j'ai une macro pour le faire donc je peux faire un call si nécessaire.

pourriez vous m'aider?

superbog · 12 Janvier 2017

personne???

superbog · 20 Janvier 2017

triste que personne n'ait d'idée, la macro de JOB75 est top mais ce pb me la rend inutilisable...

superbog · 20 Janvier 2017

triste de ne pas avoir de réponse du coup cette super macro de job75 n'est pas utilisable... sniff

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

superbog

XLDnaute Occasionnel

Pièces jointes

superbog

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

superbog

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

superbog

XLDnaute Occasionnel

superbog

XLDnaute Occasionnel

superbog

XLDnaute Occasionnel

superbog

XLDnaute Occasionnel

Discussions similaires