Code pour Mise a jour feuille Excel

Version imprimable

Bonjour

Après plusieurs heures de recherches et essais infructueux je me décide à demander un coup de main ou plutôt de souris et de clavier ;)

Mon projet consiste à mettre a jour une feuille d'un classeur local avec un fichier de données qui m'est fourni par ma direction. L'architecture de mon classeur est F1 "Explications" (avec le bouton pour la macro), F2 "Liste", F3 "DataImport"
Je souhaite supprimer les lignes qui n'existent plus et ajouter les nouvelles, sans toucher aux modifications et ajouts manuels (dans certaines cellules)
L'idéal serait que le code fonctionne pour tout type de tableau, afin qu'il puisse être utilisé dans d'autres circonstances.

J'ai donc pris le parti de rechercher le fichier source de manière manuelle et de copier les données sur une feuille du classeur de travail.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 Sub RecupereDataFichier() 'Déclaration des variables Dim ListeFichier As Variant Dim MonClasseur As Workbook 'Desactivation du presse Papiers des messages d'alerte et du rafraichissement de l'écran Application.CutCopyMode = False Application.DisplayAlerts = False Application.ScreenUpdating = False 'Efface les anciennes données Worksheets("DataImport").Cells.ClearContents 'Recherche du fichier ListeFichier = Application.GetOpenFilename(Title:="Sélectionnez le fichier", Buttontext:="Cliquez") 'Prevoir le cas du bouton annuler If ListeFichier <> False Then 'On affecte le fichier sélectionné Set MonClasseur = Application.Workbooks.Open(ListeFichier) 'Copie des données de la feuille 1 MonClasseur.Sheets(1).Range("A2").CurrentRegion.Copy 'On colle les données dans la feuille DataImport ThisWorkbook.Worksheets("DataImport").Range("A1").PasteSpecial xlPasteValues 'Fermeture du classeur source MonClasseur.Close Application.CutCopyMode = True Application.ScreenUpdating = True End If End Sub
Il me reste maintenant à supprimer les lignes obsolètes et ajouter les nouvelles de la feuille 3 "DataImport" à la feuille 2 "Liste". Et là rien de ce que j'ai essayé as fonctionné. Dans le cas précis sur lequel je travaille la colonne qui permet le "tri" est la colonne G de la feuille 2, mais idéalement j'aimerais que la "lettre" de la colonne qui serve au tri puisse être saisie dans la cellule L6 en feuille 1.

Merci d'avance de me filer un coup de main

Bonjour,

Une façon de faire:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Option Explicit
 
Sub MAJ()
   Dim wsExp As Worksheet, wsListe As Worksheet, wsData As Worksheet, rCell As Range
   Dim kR As Long, kRL As Long, kRD As Long
   Dim rListe As Range, rData As Range
   Dim sC As String
   '--- initialise
   Set wsExp = ThisWorkbook.Worksheets("Explications")
   Set wsListe = ThisWorkbook.Worksheets("Liste")
   Set wsData = ThisWorkbook.Worksheets("DataImport")
   sC = wsExp.Range("L6").Value                       '--- colonne de "tri"
   kRL = wsListe.UsedRange.Rows.Count
   kRD = wsData.UsedRange.Rows.Count
   '--- présume que les plages de données commencent en ligne n°1
   Set rListe = wsListe.Range(wsListe.Range(sC & "1"), wsListe.Range(sC & kRL))
   Set rData = wsData.Range(wsData.Range(sC & "1"), wsData.Range(sC & kRL))
   'Debug.Print rListe.Address, rData.Address
   '--- supprime lignes de "Liste" qui n'existent plus dans "DataImport"
   With rListe
      For kR = kRL To 1 Step -1                             '--- va en remontant
         If WorksheetFunction.CountIf(rData, .Cells(kR, 1)) = 0 Then
            .Cells(kR, 1).Interior.Color = vbRed
            '.Rows(kR).Delete Shift:=xlUp                    '--- supprime la ligne
         End If
      Next kR
   End With
   '--- ajoute lignes de "DataImport" qui n'existent pas dans "Liste"
   kRL = wsListe.UsedRange.Rows.Count
   With rData
      For kR = 1 To kRD
         If WorksheetFunction.CountIf(rListe, .Cells(kR, 1)) = 0 Then
            '.Cells(kR, 1).Interior.Color = vbYellow
            kRL = kRL + 1                                   '--- ligne suivante
            wsData.Rows(kR).Copy wsListe.Range("A" & kRL)   '--- copie la ligne
         End If
      Next kR
   End With
   '--- nettoie
   Set rListe = Nothing
   Set rData = Nothing
   Set wsListe = Nothing
   Set wsData = Nothing
   Set wsExp = Nothing
End Sub

mais personnellement, je n'aime pas supprimer des lignes "sans rien voir" (ligne 24), je préfère les "marquer" (ligne 23) pour les supprimer ensuite après vérification.

Cordialement.

15/03/2021, 13h05
noobyone

Bonjour
Cela fonctionne, mais il se passe quelque chose de gênant. A chaque utilisation de la macro des lignes vierges apparaissent entre les anciennes données et les nouvelles. Le plus étonnant est que le nombre de lignes vierges devient de plus en plus important à chaque utilisation.
De plus je ne sais pas comment enchainer les deux codes, j'ai essayé avec "next" en vain, du coup j'ai fait un deuxième module affecté à un deuxième bouton.
15/03/2021, 16h40
EricDgn
Bonjour,

Lancez cette macro:
Code:

1 2 3 Sub rUsed() ActiveSheet.UsedRange.Select End Sub
et vérifiez que la plage sélectionnée ne reprend bien que celle des données, qu'il n'y a pas de ligne "non prévue". C'est en effet UsedRange qui sert de base à la mise à jour.

Cordialement.
24/03/2021, 12h28
noobyone

Bonjour

J'ai trouvé la raison, il s'agissait de la mise en forme que j'avais appliquée après la fin des données. Lorsque je laisse les cellules "vierges" cela marche très bien.
Par contre je rencontre deux difficultés:
* les nouvelles données ne sont pas collées dans le tableau, c'est bien collé sur la ligne d'après mais cella ne suffit pas pour utiliser les filtres de colonne
* sur certaines données collées il faut appliquer un format spécifique (date)

J'ai également identifié un besoin, que j'avais oublié.
Il faut mettre à jour des données sur des lignes déjà existantes, il s'agit de la colonne C. J'aimerais comme précédemment pouvoir l'identifier via la feuille 1 ('EXPLICATIONS') en cellule E3.
Dans ce cas serait il possible d'en mettre plusieurs ex: C,F,AB ?

merci d'avance !!
bonne journée

1 pièce(s) jointe(s)

Bonjour,

Un début de solution travaillant sur des tableaux structurés, ce qui règle le problème de tri - filtration - formats conditionnels, mais ne gérant que 1 seule colonne mentionnée en E3, et donc à adapter pour le cas de plusieurs colonnes.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Sub MAJ_Tableau()
   '--- il est présumé que les colonnes sont exactement dans le même ordre dans les 2 tableaux
   Dim wsExp As Worksheet, loListe As ListObject, loData As ListObject
   Dim rCell As Range, kR As Long, kRL As Long, kRD As Long
   Dim kRdata0 As Long, kRliste0 As Long
   Dim rListe As Range, rData As Range, rValData As Range, rValListe As Range
   Dim sCid As String, sCval As String
   '--- initialise
   Set wsExp = ThisWorkbook.Worksheets("Explications")
   Set loListe = ThisWorkbook.Worksheets("Liste").ListObjects("Tableau1")
   Set loData = ThisWorkbook.Worksheets("DataImport").ListObjects("Tableau2")
   sCid = wsExp.Range("L6").Value            '--- titre colonne identifiant unique
   sCval = wsExp.Range("E3").Value           '--- titre colonne dont les valeurs sont à mettre à jour
   kRL = loListe.ListRows.Count + 1
   kRD = loData.ListRows.Count
   '--- plage de données de la colonne sCid
   Set rListe = loListe.ListColumns(sCid).Range
   Set rData = loData.ListColumns(sCid).Range
   Set rValListe = loListe.ListColumns(sCval).Range
   Set rValData = loData.ListColumns(sCval).Range
   kRdata0 = loData.HeaderRowRange.Row - 1
   kRliste0 = loListe.HeaderRowRange.Row - 1
   'Debug.Print rListe.Address, rData.Address
   '--- supprime lignes de "Liste" qui n'existent plus dans "DataImport"
   With rListe
      For kR = kRL To 1 Step -1                                '--- va en remontant
         Set rCell = rData.Find(.Cells(kR, 1).Value, , , xlWhole)
         If rCell Is Nothing Then
            '--- la ligne n'existe plus
            .Cells(kR, 1).Interior.Color = vbRed
            '.Rows(kR).Delete Shift:=xlUp                      '--- supprime la ligne
         Else
            '--- la ligne existe
            '--- reprend valeur de cellule du tableau Data dans tableau Liste
            rValListe.Cells(kR, 1).Value = rValData.Cells(rCell.Row - kRdata0, 1).Value
         End If
      Next kR
   End With
   '--- ajoute lignes de "DataImport" qui n'existent pas dans "Liste"
   kRL = loListe.ListRows.Count
   With rData
      For kR = 2 To kRD + 1
         Debug.Print .Cells(kR, 1)
         If WorksheetFunction.CountIf(rListe, .Cells(kR, 1)) = 0 Then
            '.Cells(kR, 1).Interior.Color = vbYellow
            kRL = kRL + 1                                               '--- n° ligne suivante
            loListe.ListRows.Add                                        '--- ajoute ligne au tableau
            '--- copie valeurs de toute la ligne du tableau Data dans tableau Liste
            loListe.ListRows(kRL).Range.Value = loData.ListRows(kR - 1).Range.Value
         End If
      Next kR
   End With
   '--- nettoie
   Set rCell = Nothing
   Set rValListe = Nothing
   Set rValData = Nothing
   Set rListe = Nothing
   Set rData = Nothing
   Set loListe = Nothing
   Set loData = Nothing
   Set wsExp = Nothing
End Sub

Bonne continuation.

29/03/2021, 08h35
noobyone

2 pièce(s) jointe(s)

Bonjour

Merci de votre réponse si rapide.
Malheureusement cela ne marche pas du tout, j'ai essayé sur deux classeurs où la version antérieure de la macro fonctionnait.
J'arrive à ce message d'erreur:
Pièce jointe 594488
Cela que je renseigne le "titre" de la colonne ou sa lettre. Pourtant avec votre fichier cela fonctionne très bien.

Du coup je vous envoie l'un des classeurs si vous voulez bien regarder ce qui cloche.

Merci
Bonne soirée
29/03/2021, 22h03
EricDgn

1 pièce(s) jointe(s)

Bonjour,

C'est simplement du au fait que le nom de la macro a été changé de MAJ() en MAJ_tableau().

Cordialement.
31/03/2021, 12h04
noobyone

1 pièce(s) jointe(s)

Bonjour

Merci de votre aide, ah mince je n'avais pas fait attention à ça.
Malheureusement cela ne fonctionne toujours pas:
Pièce jointe 594655
Le débogueur m'envoie à la ligne 17 du code:

Code:

Set rListe = loListe.ListColumns(sCid).Range

Je ne comprends pas ce qui coince ..
01/04/2021, 23h52
EricDgn

Bonjour,

L'erreur vient de cette ligne

Code:

sCid = wsExp.Range("L6").Value '--- titre colonne identifiant unique

où il faudrait remplacer "L6" par "L5".

Cordialement.

Bonjour

J'espère que vous avez passé un bon weekend.
Merci encore pour votre aide précieuse, je pense que j'arrive bientôt au résultat attendu. Encore un soucis (espérons que ce soit le dernier)

Code:

Set loData = ThisWorkbook.Worksheets("DataImport").ListObjects("Tableau2")

Le problème vient de l'import des données qui supprime la mise en forme existante, le tableau 2 n'existe donc plus à chaque fois que je lance la première macro.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Sub RecupereDataFichier()
'Déclaration des variables
Dim ListeFichier As Variant
Dim MonClasseur As Workbook
 
 
'Desactivation du presse Papiers des messages d'alerte et du raffraichissement de l'écran
Application.CutCopyMode = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
 
'Efface les anciennes données
Worksheets("DataImport").Cells.ClearContents
 
'Recherche du fichier
ListeFichier = Application.GetOpenFilename(Title:="Sélectionnez le fichier", Buttontext:="Cliquez")
 
'Prevoir le cas du bouton annuler
If ListeFichier <> False Then
    'On affecte le fichier sélectionné
    Set MonClasseur = Application.Workbooks.Open(ListeFichier)
 
    'Copie des données de la feuille 1
    MonClasseur.Sheets(1).Range("A2").CurrentRegion.Copy
    'On colle les données dans la feuille DataImport
    ThisWorkbook.Worksheets("DataImport").Range("A1").PasteSpecial xlPasteValues
 
 
    'Fermeture du classeur source
    MonClasseur.Close
     Application.CutCopyMode = True
     Application.ScreenUpdating = True
    End If
 
    'Affiche la feuille EXPLICATIONS
   Sheets("EXPLICATIONS").Activate
    End Sub

Du coup je pensais à modifier la première macro pour "respecter" la mise en forme tableau.

1 pièce(s) jointe(s)

Bonjour,

Le problème vient de l'instruction Cells.ClearContents en ligne 14 qui efface tout. Le tableau Tableau2 est lui-même supprimé. Pour contourner cela, il faut plutôt utiliser l'instruction Resize pour redimensionner le tableau à la taille du tableau à recopier (voir ligne 28 du code ci-dessous). Une façon de faire:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Option Explicit
 
Sub RecupereDataFichier()
    '--- il est présumé que les données commencent dans la cellule A1
    '--- et que le nombre de colonnes est identique partout
    Dim ListeFichiers As Variant, MonClasseur As Workbook
    Dim loData As ListObject, sLastCell As String
    'Desactivation du presse-papiers, des messages d'alerte, du raffraichissement de l'écran
    Application.CutCopyMode = False
    'Application.DisplayAlerts = False
    'Application.ScreenUpdating = False
    Set loData = ThisWorkbook.Worksheets("DataImport").ListObjects("Tableau2")
    'vide la partie données de Tableau2
    loData.DataBodyRange.ClearContents
    'recherche du fichier
    ListeFichiers = Application.GetOpenFilename(Title:="Sélectionnez le fichier", Buttontext:="Cliquez")
    'Prevoir le cas du bouton annuler
    If ListeFichiers <> False Then
        'affecte le fichier sélectionné
        Set MonClasseur = Application.Workbooks.Open(ListeFichiers)
        'utilise feuille 1 du fichier sélectionné
        With MonClasseur.Sheets(1)
            'adresse dernière cellule données à copier
            sLastCell = .UsedRange.Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count).Address(False, False)
            .Range(sLastCell).Select
            If MsgBox("Recopier la plage A2:" & sLastCell & " ?", vbYesNo, "A confirmer") = vbYes Then
                'redimensionne Tableau2 à la taille des données recopiées
                loData.Resize Range("A1:" & sLastCell)
                'copie les données (sans la ligne des titres)
                .Range("A2:" & sLastCell).Copy
                'colle les données dans Tableau2
                ThisWorkbook.Worksheets("DataImport").Range("A2").PasteSpecial xlPasteValues
            End If
        End With
        'ferme le classeur source
        MonClasseur.Close
    End If
    Set loData = Nothing
    Application.CutCopyMode = True
    Application.ScreenUpdating = True
    'Affiche la feuille EXPLICATIONS
    Sheets("EXPLICATIONS").Activate
End Sub

A noter que j'ai ajouté une demande de confirmation de la plage à recopier car je crains que la feuille Excel importée ne soit pas tout à fait "propre" (cellules qui semblent vides mais qui ne le sont pas vraiment).

Par ailleurs, il y a aussi un risque de dépassement de la capacité du presse-papier. Il serait préférable de comparer directement la feuille sélectionnée Sheets(1) à la feuille "Liste" plutôt que de la copier puis de la comparer.

Cordialement.

21/04/2021, 12h13
noobyone

Merci beaucoup !!
Tout marche très bien, merci de votre temps.

Bonne journée