[vba Excel] mise à jour de tableau

**ancel17** · 24/05/2007, 15h02

Bonjour !

j'ai un fichier Excel avec plusieurs feuilles (sommaire, sous-rubrique1,...sous-rubriquen).
Dans toutes mes feuilles "sous-rubrique", j'ai un tableau dont la structure ne varie pas.

je voudrais savoir comment récupérer automatiquement les lignes des tableaux de toutes les feuilles "sous-rubrique" et les insérer au tableau de la feuille "sommaire".

Merci de vos réponses !

**ouskel'n'or** · 26/05/2007, 15h01

Tu as deux solutions, ou tu copies 'plage de données' par 'plage de données' dans ta feuille sommaire.
Ou tu copies tes plages ligne par ligne
Pour la solution par plage, tu peux tester ça

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub RassemblerLesFeuillesDunClasseurDansUneSeule()
Dim CL1 As Workbook
Dim FL1 As Worksheet, LaFeuille as Worksheet
    Set CL1 = Workbooks("Liste pour fusion.xls")
    Set FL1 = CL1.Worksheets("Sommaire")
    For Each LaFeuille In CL1.Worksheets
        If Not LaFeuille.Name = FL1.Name Then _
            LaFeuille.Range("A2:" & LaFeuille.Range("A1"). _
            SpecialCells(xlCellTypeLastCell).Address).Copy _
            Destination:=FL1.Range("A" & FL1.Range("A1"). _
            SpecialCells(xlCellTypeLastCell).Row + 1)
    Next
    Set FL1 = Nothing
    Set CL1 = Nothing
End Sub

A+

Edit
Je fais commencer la copie en A2 (LaFeuille.Range("A2:"...) afin de ne pas copier l'entête éventuelle des feuilles copiées
Si pas d'entête -> LaFeuille.Range("A1:" ...

NB - Avant copie, ton fichier doit être enregistré pour que
Range("A1").SpecialCells(xlCellTypeLastCell)
donne l'exact N° de dernière cellule de la plage de données à copier
ou le N° de la première cellule vide où coller

**ancel17** · 29/05/2007, 12h27

Merci pour ton aide !

voici le code actuel :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Private Sub Worksheet_Activate()
Dim CL1 As Workbook
Dim FL1 As Worksheet, LaFeuille As Worksheet
    Set CL1 = Workbooks("Air.xls")
    Set FL1 = CL1.Worksheets("Sommaire")
    With FL1.Rows("15:65536")
        .ClearContents
        .Delete
    End With
    For Each LaFeuille In CL1.Worksheets
        If Not LaFeuille.Name = FL1.Name Then _
            LaFeuille.Range("A15:" & LaFeuille.Range("A1"). _
            SpecialCells(xlCellTypeLastCell).Address).Copy _
            Destination:=FL1.Range("A" & FL1.Range("A1"). _
            SpecialCells(xlCellTypeLastCell).Row + 1)
        Next
    Set FL1 = Nothing
    Set CL1 = Nothing
End Sub

j'ai inséré un bloc with car je souhaite que mon tableau de la feuille "sommaire" soit recalculé à chaque fois que la feuille est affichée. J'ai donc essayé .ClearContents, puis .Delete, puis les deux pour essayer de résoudre mon problème qui est le suivant :

les données importées des autres feuilles du classeur sont copiées à la suite du tableau précédent (bien que les lignes du tableau soient préalablement supprimées)

j'obtiens donc un tableau avec n lignes vides correspondant aux lignes des données précédentes et m lignes correctement remplies correspondant aux lignes des nouvelles données.

Vois-tu où est le problème ?

**ancel17** · 29/05/2007, 12h37

Désolé pour le dérangement, j'ai trouvé la solution que j'avais déjà dans ta première réponse...
j'ai juste un peu zappé ton NB et du coup, je n'enregistrais pas mon fichier avant de copier mes données.

Voici le code qui fonctionne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Sub Worksheet_Activate()
Dim CL1 As Workbook
Dim FL1 As Worksheet, LaFeuille As Worksheet
    Set CL1 = Workbooks("Air.xls")
    Set FL1 = CL1.Worksheets("Sommaire")
    FL1.Rows("15:65536").Delete
    CL1.Save
    For Each LaFeuille In CL1.Worksheets
        If Not LaFeuille.Name = FL1.Name Then _
            LaFeuille.Range("A15:" & LaFeuille.Range("A1"). _
            SpecialCells(xlCellTypeLastCell).Address).Copy _
            Destination:=FL1.Range("A" & FL1.Range("A1"). _
            SpecialCells(xlCellTypeLastCell).Row + 1)
        Next
    Set FL1 = Nothing
    Set CL1 = Nothing
End Sub

Toujours dans le meme style mais en un peu plus compliqué, je voudrais maintenant importer les données de mes tableaux "sommaire" (j'ai plusieurs fichiers .xls différents) dans un tableau situé dans un autre classeur.

Comment faire ?

**ouskel'n'or** · 29/05/2007, 12h59

Ou tu veux lister les fichiers d'un répertoire particulier, ou tu connais les noms et chemins des fichiers à "agglutiner", auquel cas tu en fais un tableau.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
LeTableau = Array("D:\xls\Sommaire1.xls", "D:\xls\Sommaire2.xls", "D:\xls\Sommaire3.xls", "D:\xls\Sommaire4.xls")
 
'le classeur contenant la macro et dans lequel tu colles les feuilles sommaire
Set Fl1 = ThisWorkbook
 
'La boucle
For i = 1 to Ubound(LeTableau)
     Set FL2 = Workbooks.open LeTableau(i)
     'Copie de la feuille
     FL1. 'collage
     DoEvents
     FL2.close false
Next

et là tu dois pouvoir adapter à ton nouveau fichier le code qui t'a servi pour créer le sommaire.
A+

**ancel17** · 29/05/2007, 15h17

Tout d'abord merci pour tes réponses !

Voici le code que j'ai inséré dans le classeur qui reçoit les données :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub Worksheet_Activate()
 
Dim fso As New FileSystemObject
Dim fich As file
Dim Rep As Folder
Dim Wk As Variant
Dim TabFich() As String
    Set Rep = fso.GetFolder(Application.ThisWorkbook.Path & "\Thèmes")
    For Each fich In Rep.Files
        Wk = Chemin & fich.Name
         'Renseigne une listbox
        If fso.GetExtensionName(Wk) = "xls" Then _
           listbox1.AddItem Wk
        End If
    Next
    Set Rep = Nothing
 
Dim CL1 As Workbook, CL2 As Workbook
Dim FL1 As Worksheet, FL2 As Worksheet
    Set CL1 = ThisWorkbook
    Set FL1 = CL1.Worksheets("Sommaire")
    FL1.Rows("74:65536").Delete
    CL1.Save
    For i = 1 To UBound(listbox1)
        Set CL2 = Workbooks.Open(listbox1(i))
        Set FL2 = CL2.Worksheets("sommaire")
        FL2.Range("A15:" & FL2.Range("A1"). _
        SpecialCells(xlCellTypeLastCell).Address).Copy _
        Destination:=FL1.Range("A" & FL1.Range("A1"). _
        SpecialCells(xlCellTypeLastCell).Row + 1)
    Next i
 
    Set FL1 = Nothing
    Set CL1 = Nothing
    Set FL2 = Nothing
    Set CL2 = Nothing
 
End Sub

Je ne sais pas si cela peut fonctionner étant donné que j'ai une erreur dès la première ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Dim fso As New FileSystemObject

L'erreur est la suivante :

Erreur de compilation :
Type défini par l'utilisateur non défini

Qu'en penses-tu ?

**ouskel'n'or** · 29/05/2007, 15h52

Oui, tu dois valider la référence la reference "Microsoft Scripting RunTime" -> Editeur VB -> Outils -> Références.
Dis-moi où tu as pris le code que j'ajoute ce renseignement

A+

Edit
Fais attention, ce code ajoute le nom de fichier à une liste.
Tu supprimes la ligne " listbox1.AddItem Wk" que tu remplaces par Ouverture Wk -> Sélectionner tout -> copier/coller... enfin, bref, le code qui va bien.
En l'occurence, à la place de FL2, tu utilises Wk puis qu'il existe dans le code.
A+

PS - là où tu as pris le code, c'est écrit "Ce code nécessite la validation de la référence "Microsoft Scripting RunTime". Non mais !

**ancel17** · 29/05/2007, 16h11

j'ai pris ce code ici

je vais voir si je parviens à faire ce qu'il faut pour que ça fonctionne.
En tout cas c'est bon de se sentir soutenu !

**ancel17** · 29/05/2007, 18h57

Voila, maintenant le code fonctionne correctement, et le voici :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub Worksheet_Activate()
 
Dim fso As New FileSystemObject
Dim fich As file
Dim Rep As Folder
Dim Wk As Variant
Dim TabFich() As String
Dim CL1 As Workbook, CL2 As Workbook
Dim FL1 As Worksheet, FL2 As Worksheet
 
    Set CL1 = ThisWorkbook
    Set FL1 = CL1.Worksheets("Sommaire")
    Set Rep = fso.GetFolder(Application.ThisWorkbook.Path & "\Thèmes")
 
            FL1.Rows("74:65536").Delete
 
            For Each fich In Rep.Files
                Wk = Rep & "\" & fich.Name
                If fso.GetExtensionName(Wk) = "xls" Then
                    CL1.Save
                    Set CL2 = Workbooks.Open(Wk)
                    Set FL2 = CL2.Worksheets("sommaire")
                        FL2.Range("A15:" & FL2.Range("A1"). _
                        SpecialCells(xlCellTypeLastCell).Address).Copy _
                        Destination:=FL1.Range("B" & FL1.Range("B1"). _
                        SpecialCells(xlCellTypeLastCell).Row + 1)
                        CL2.Close
                End If
            Next
 
    Set Rep = Nothing
    Set FL1 = Nothing
    Set CL1 = Nothing
    Set FL2 = Nothing
    Set CL2 = Nothing
 
End Sub

J'ai juste encore un petit souci : j'aimerai que le tableau soit recalculé à chaque fois que la feuille est affichée (si je navigue d'un fichier xls à un autre, lorsque je reviens sur le fichier avec le tableau, le fichier n'est pas mis à jour).
Pour voir le code fonctionner, j'ai du insérer une deuxième feuille au classeur pour faire la bascule...

Autre question, est-il possible de ne pas voir à l'écran l'ouverture et la fermeture de chaque fichier ?

Et enfin la dernière... pour l'instant : comment pour chaque ligne collée, affecter à la première colonne le nom du fichier d'origine ?

**ouskel'n'or** · 29/05/2007, 19h37

j'aimerai que le tableau soit recalculé à chaque fois que la feuille est affichée (si je navigue d'un fichier xls à un autre, lorsque je reviens sur le fichier avec le tableau, le fichier n'est pas mis à jour).

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Application.Calculate

Mais regarde à Calculate, dans l'aide, elle t'en dit plus et tu pourras mettre ce qui te convient le mieux.

Autre question, est-il possible de ne pas voir à l'écran l'ouverture et la fermeture de chaque fichier ?

Il y a une solution mais en cas de bug, elle est (très) risquée. En voici une que tu peux tester, après la ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
                    Set CL2 = Workbooks.Open(Wk)
                    CL2.visible = False

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Et enfin la dernière... pour l'instant : comment pour chaque ligne collée, affecter à la première colonne le nom du fichier d'origine ?

Là, je dis "Ouf !"
Si tu avais copié tes feuilles ligne par ligne c'eut été plus long mais aussi plus simple.
Une proposition en l'état : Consiste à tester la colonne en question.
On part de la première feuille copiée. Pour remplir ta colonne du nom du fichier, tu cherches la dernière ligne renseignée de ta (nouvelle) plage de données et tu places Wk sur toutes les cellules de la colonne jusqu'à dernière ligne.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
PremLign = 1 'ou 2 si tu as un en-tête
Derlig = Range("A1").SpecialCells(xlCellTypeLastCell).Row
For i = PremLign to Derlig
     Cells(i, NoCol).value = WK
Next

Tu peux aussi ne le coller qu'une fois et recopier vers le bas jusqu'à la fin de ta plage.
Pour la seconde feuille copiée et les suivantes, tu pars de la première cellule vide

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

PremLig = Range("A65535").End(xlUp).Row + 1

(code que tu peux utiliser pour la première feuille collée, à la réflexion...) tu pars donc de la première cellule vide à la nouvelle dernière ligne de ta plage

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Range("A1").SpecialCells(xlCellTypeLastCell).Row

Tu dois insérer ce code apès collage de la feuille dans sommaire
N'oublie pas d'indiquer la bonne feuille (FL1.Range("A65535").End.....)

A+

Edit
Tout bien corrigé, ça donnerait ça

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
PremLig = FL1.Range("A65535").End(xlUp).Row + 1
Derlig = FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row
For i = PremLig to Derlig
     FL1.Cells(i, NoCol).value = WK
Next

et ça après collage de chaque feuille
Déclare les variables as long

**ancel17** · 29/05/2007, 21h02

je pense qu'il vaudrait mieux remplacer Wk par fich.Name car Wk me donne le chemin complet...

D'autre part est-il possible de retirer l'extention car fich.Name renvoie par exemple Air.xls alors que je voudrais avoir que Air ?

Il y a une solution mais en cas de bug, elle est (très) risquée. En voici une que tu peux tester, après la ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Set CL2 = Workbooks.Open(Wk)
CL2.visible = False

Ceci ne fonctionne pas :

Propriété ou méthode non gérée par cet objet

Tout bien corrigé, ça donnerait ça

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
PremLig = FL1.Range("A65535").End(xlUp).Row + 1
Derlig = FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row
For i = PremLig to Derlig
     FL1.Cells(i, NoCol).value = WK
Next

et ça après collage de chaque feuille
Déclare les variables as long

Cela fonctionne très bien mis à part la valeur prise par les cellules (.xls en trop). J'ai trouvé comment faire pour centrer automatiquement la valeur de la cellule, mais pas pour encadrer la cellule.

Pour Application.Activate, je vois pas trop comment faire, mais je vais chercher.

**ouskel'n'or** · 29/05/2007, 21h12

Et d'abord c'est Application.Calculate pas Activate...
Pour le nom de fichier, tu peux mettre

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Cells(....).value = Left(Split(Wk,"\")(Ubound(Split(Wk,"\"),len(Split(Wk,"\")(Ubound(Split(Wk,"\")-4)

Je plaisante bien que ça risque de fonctionner. Prends plutôt

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Cells(...).value = Left(fich.Name, len(fich.Name)-4)

A+

**ancel17** · 30/05/2007, 08h53

Et d'abord c'est Application.Calculate pas Activate...

on est d'accord, c'est juste une erreur de ma part lors du post...

Sinon pour le nom du fichier, c'est nickel

**ouskel'n'or** · 30/05/2007, 09h25

Application.calculate ne fonctionne pas ? Tu as jeté un coup d'oeil dans l'aide ?

**ancel17** · 30/05/2007, 09h33

c'est à dire que si je mets application.calculate dans la sub worksheet_activate, ce n'est pris en compte que lorsque la feuille sommaire est dans l'état actif, ce qui n'est jamais le cas lors d'un retour après navigation entre différents fichiers.

D'ailleurs je me suis rendu compte ce matin que le tableau n'était pas recalculé lors de l'ouverture du fichier...

sinon, pour les bordures des cellules, tu as une solution ? j'ai essayé borders, mais c'est pas géré par Cells.

**ouskel'n'or** · 30/05/2007, 09h55

Tu veux encadrer les feuilles rassemblées ?
Je ne sais plus les noms de feuilles mais pour la syntaxe...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Bordure()
with worksheets("Feuil1").range("A1:" & Worksheets("Feuil1").range("A1").SpecialCells(xlCellTypeLastCell).Address(false, false))
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With .Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End With
 
End Sub

Que tu peux simplifier si tu veux des lignes classiques, noires, de l'épaisseur par défaut.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
With Worksheets("Feuil1").Range("A1:" & Worksheets("Feuil1").Range("A1").SpecialCells(xlCellTypeLastCell).Address(False, False))
    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Borders(xlEdgeTop).LineStyle = xlContinuous
    .Borders(xlEdgeBottom).LineStyle = xlContinuous
    .Borders(xlEdgeRight).LineStyle = xlContinuous
    .Borders(xlInsideVertical).LineStyle = xlContinuous
    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With

A+

Essaie FL1.Calculate

**ancel17** · 30/05/2007, 11h12

Merci pour les bordures !

Voici le code complet actuel. Le souci qu'il reste vient toujours du fait que le tableau n'est pas recalculé automatiquement à chaque affichage de la feuille, que ce soit à l'ouverture du fichier, ou au retour après navigation.
Actuellement, je suis toujours obligé de basculer d'une feuille à une autre pour que le tableau soit calculé.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub Worksheet_Activate()
 
Dim fso As New FileSystemObject
Dim fich As file
Dim Rep As Folder
Dim Wk As Variant
Dim TabFich() As String
Dim CL1 As Workbook, CL2 As Workbook
Dim FL1 As Worksheet, FL2 As Worksheet
Dim Premlig As Long, Derlig As Long
 
    FL1.Calculate
 
    Set CL1 = ThisWorkbook
    Set FL1 = CL1.Worksheets("Sommaire")
    Set Rep = fso.GetFolder(Application.ThisWorkbook.Path & "\Thèmes")
 
            FL1.Rows("74:65536").Delete
 
            For Each fich In Rep.Files
                Wk = Rep & "\" & fich.Name
                If fso.GetExtensionName(Wk) = "xls" Then
                    CL1.Save
                    Premlig = FL1.Range("A65535").End(xlUp).Row + 1
                    Set CL2 = Workbooks.Open(Wk)
                    Set FL2 = CL2.Worksheets("sommaire")
                        FL2.Range("A15:" & FL2.Range("A1"). _
                        SpecialCells(xlCellTypeLastCell).Address).Copy _
                        Destination:=FL1.Range("B" & FL1.Range("B1"). _
                        SpecialCells(xlCellTypeLastCell).Row + 1)
                        Derlig = FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row
                        For i = Premlig To Derlig
                            FL1.Cells(i, 1).Value = Left(fich.Name, Len(fich.Name) - 4)
                        Next
                        CL2.Close
                End If
            Next
            With FL1.Range("A74:" & "G" & FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row)
                .VerticalAlignment = xlVAlignCenter
                .HorizontalAlignment = xlHAlignCenter
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlContinuous
                .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            End With
 
    Set Rep = Nothing
    Set FL1 = Nothing
    Set CL1 = Nothing
    Set FL2 = Nothing
    Set CL2 = Nothing
 
End Sub

En tout cas, merci pour ton aide qui m'a déjà été très précieuse !

**ouskel'n'or** · 30/05/2007, 11h30

Je vois que tu places FL1.Calculate en tête de macro, c'est à placer après tout ton code, juste avant set FL1 = Nothing (voui, parce que sinon FL1 il est pas reconnu

)
Tu me tiens au courant
A+

**ancel17** · 30/05/2007, 11h58

Certes, mais ça ne change le fait que la sub est prise en compte sur l'activation de la feuille.

J'ai déplacé la ligne au bon endroit, mais ça ne fonctionne pas mieux (vu que ça ne fonctionnait déjà pas avant

)

**ouskel'n'or** · 30/05/2007, 12h35

Remplace la ligne par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
If Application.CalculationVersion <> _
    Workbooks(1).CalculationVersion Then
    Application.CalculateFull
End If

Si ça fonctionne, tu pourras simplifier en ne mettant que la dernière ligne
Tu dis

En désespoir de cause

[vba Excel] mise à jour de tableau

Macros et VBA Excel

Discussions similaires

Partager

Partager