Ventilation de données sur plusieurs feuilles

**drylanda** · 21/03/2021, 14h50

Bonjour à tous !
Merci d'avance pour le fait de réfléchir à ma préoccupation.
Le classeur que je m'en vais vous soumettre me permet d'analyser au quotidien l'évolution de certains stocks. Je voudrais ventiler les données qui se trouvent dans la feuille "TODAY" vers les 36 autres feuilles/onglets contenues dans le classeur. Le code VBA exploité ici agit de manière à copier entièrement une ligne de la feuille "TODAY" s'il y à correspondance entre le contenu de la cellule "B" (2è colonne) et une des 36 feuilles/onglets de ce classeur. Après quelques jours de recherche,, j'ai pu trouver un code VBA et l'ajuster à mes besoins. Ma première préoccupation est que je cherche à ce que Excel en collant les données procède à une fusion de la mise en forme conditionnelle (collage spécial/fusionner la mise ne forme conditionnelle). En L'état actuel, lorsque la commande s'exécute, la mise en forme déjà présente sur la ligne ou les données sont collées s'efface.

Merci.

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
Dim j As Integer
Dim LastRow_SOURCE As Long
Dim LastRow As Long
 
Public Sub Ventilation()
    Application.ScreenUpdating = False
 
    'on part de la source
    LastRow_TODAY = Sheets("TODAY").Range("A" & Rows.Count).End(xlUp).Row
    'on boucle dans la source
    For k = 2 To LastRow_TODAY
       'boucle permettant de lire toutes les 36 feuilles du classeur
        For j = 1 To 36
            With Sheets(j)
                'ventiler les noms de la colonne 2 dans chaque feuille si celui-ci a le meme intitulé que la feuille
                If .Name = Sheets("TODAY").Cells(k, 2).Value Then
                    LastRow = .Range("A" & Rows.Count).End(xlUp).Row
                    Sheets("TODAY").Range("A" & k).EntireRow.Copy Destination:=.Cells(Rows.Count, 1).End(xlUp)(2)
                End If
            End With
        Next j
    Next k
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

**anasecu** · 21/03/2021, 18h16

Bonjour,

Envoyé par drylanda

En L'état actuel, lorsque la commande s'exécute, la mise en forme déjà présente sur la ligne ou les données sont collées s'efface.

Pour corriger cela, je te propose ce code :

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
Public Sub Ventilation()
Dim LastRow_TODAY As Long
Dim LastRow As Long
Dim k As Long
    Application.ScreenUpdating = False
    'on part de la source
    LastRow_TODAY = Sheets("TODAY").Range("A" & Rows.Count).End(xlUp).Row
    'on boucle dans la source
    For k = 2 To LastRow_TODAY
       'boucle permettant de lire toutes les 32 feuilles du classeur
            With Sheets(Sheets("TODAY").Cells(k, 2).Value)
                'ventiler les noms de la colonne 7 dans chaque feuille si celui-ci a le meme intitulé que la feuille
                LastRow = .Range("A" & Rows.Count).End(xlUp).Row
                .Rows(LastRow).EntireRow.Copy
                .Rows(LastRow + 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
                Sheets("TODAY").Rows(k).Copy
                .Rows(LastRow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
            End With
    Next k
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Cependant pour éviter ton problème, il aurait été judicieux de fonctionner avec des tableaux structurés et tu n'aurais pas eu de soucis.

**drylanda** · 21/03/2021, 20h57

Bonsoir Anasecu, Merci pour ta proposition. J'essaie ton code et je te reviens. Je ferai quelques recherches mais pourrais tu stp déjà m'éclairer sur les tableaux structurés ?

**drylanda** · 21/03/2021, 21h49

ANASECU, LE CODE FONCTIONNE PARFAITEMENT BIEN. MERCI

J'aurais stp autre requête. Je souhaite à la suite du précédent code, pouvoir avoir sur une feuille que je nommerai par exemple "two last days" et qui copira les deux dernières lignes de tous les autres feuilles à l'exception de "TODAY". Voici un aperçu du résultat attendu, en pièce jointe portant avec les 5 premières feuilles.

Nom : Screenshot 2021-03-21 213440.png
Affichages : 358
Taille : 121,7 Ko

Nom : Screenshot 2021-03-21 213440.png
Affichages : 358
Taille : 121,7 Ko

**anasecu** · 21/03/2021, 23h25

Bonsoir

Envoyé par drylanda

Je souhaite à la suite du précédent code, pouvoir avoir sur une feuille que je nommerai par exemple "two last days" et qui copira les deux dernières lignes de tous les autres feuilles

Cela peut se faire en même temps avec en gras les rajouts comme ceci :

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
Option Explicit
Public Sub Ventilation()
Dim LastRow_TODAY As Long
Dim LastRow As Long
Dim k As Long
Dim lig As Long
    Application.ScreenUpdating = False
    'on part de la source
    LastRow_TODAY = Sheets("TODAY").Range("A" & Rows.Count).End(xlUp).Row
    'on boucle dans la source
    lig = 3
    For k = 2 To LastRow_TODAY
       'boucle permettant de lire toutes les 32 feuilles du classeur
            With Sheets(Sheets("TODAY").Cells(k, 2).Value)
                'ventiler les noms de la colonne 7 dans chaque feuille si celui-ci a le meme intitulé que la feuille
                LastRow = .Range("A" & Rows.Count).End(xlUp).Row
                .Rows(LastRow).EntireRow.Copy
                .Rows(LastRow + 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
                Sheets("TODAY").Rows(k).Copy
                .Rows(LastRow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
                .Rows(LastRow).Resize(3).EntireRow.Copy Destination:=Sheets("two last days").Rows(lig)
                lig = lig + 3
            End With
    Next k
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Ainsi ta nouvelle feuille est toujours mise à jour de concert.

**drylanda** · 22/03/2021, 16h25

Bonjour Anasecu, Merci pour le travail abattu jusque là. Le code fonctionne à une exception près. Il semble que vu que le stock "SILVER" ne soit pas parmi les stocks du "19/03/2021" dans la feuille "TODAY", les deux dernières lignes de la feuille "SILVER" n'ai pas été copiée vers la feuille "two last days". Pourrais tu stp me voir ça ?

**anasecu** · 22/03/2021, 18h36

Bonjour drylanda,

Envoyé par drylanda

les deux dernières lignes de la feuille "SILVER" n'ai pas été copiée vers la feuille "two last days". Pourrais tu stp me voir ça ?

Tu avais effectivement dis "qui copira les deux dernières lignes de tous les autres feuilles à l'exception de "TODAY" mais tu as aussi des feuilles sans données autre que "TODAY" dont tu n'as pas tenu compte.
Essaies avec ce code :

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
Option Explicit
Public Sub Ventilation()
Dim LastRow_TODAY As Long
Dim LastRow As Long
Dim k As Long
Dim lig As Long
Dim ws As Worksheet
    Application.ScreenUpdating = False
    LastRow_TODAY = Sheets("TODAY").Range("A" & Rows.Count).End(xlUp).Row
    For k = 2 To LastRow_TODAY       'boucle permettant de copier les lignes de TODAY
        With Sheets(Sheets("TODAY").Cells(k, 2).Value)
            LastRow = .Range("A" & Rows.Count).End(xlUp).Row
            .Rows(LastRow).EntireRow.Copy
            .Rows(LastRow + 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
            Sheets("TODAY").Rows(k).Copy
            .Rows(LastRow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        End With
    Next k
    lig = 3
    For Each ws In ThisWorkbook.Sheets 'boucle permettant de copier les 2 dernières lignes dans two last days
        If InStr("two last days,TODAY", ws.Name) = 0 Then
            LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row - 1
            If LastRow > 3 Then
                ws.Rows(LastRow).Resize(3).EntireRow.Copy Destination:=Sheets("two last days").Rows(lig)
                lig = lig + 3
            End If
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

**drylanda** · 23/03/2021, 23h01

Bonsoir Anasecu, j'intègre ton nouveau code et je te reviendrai. Encore merci.

**drylanda** · 24/03/2021, 12h11

Bonjour Anasecu. Voici l'évolution du fichier en pièce jointe avec les données d'hier que j'ai essayé de répartir avec le dernier code fourni. Mais un message d'erreur s'affiche. J'ai également remarqué qu'en copiant les deux dernières lignes vers "two last days", il copie également la ligne des titres (ceci concerne uniquement par exemple la feuille XLP qui recevra pour la première fois des données).

**anasecu** · 24/03/2021, 19h05

Bonjour drylanda,

Envoyé par drylanda

un message d'erreur s'affiche. ... il copie également la ligne des titres (ceci concerne uniquement par exemple la feuille XLP qui recevra pour la première fois des données).

Le message erreur vient du fait que tu as des formules dans tes feuilles sur lesquelles tu fais des copies : c'est assez curieux car elles seront écrasées par les copies.
J'ai utilisé une autre procédure pour contourner l'anomalie et il faut 2 lignes de données pour aller dans "two last days".

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
Option Explicit
Public Sub Ventilation()
Dim LastRow_TODAY As Long
Dim LastRow As Long
Dim k As Long
Dim lig As Long
Dim ws As Worksheet
    Application.ScreenUpdating = False
    LastRow_TODAY = Application.Match(9 ^ 9, Sheets("TODAY").Range("A:A"), 1)
    For k = 2 To LastRow_TODAY       'boucle permettant de copier les lignes de TODAY
        With Sheets(Sheets("TODAY").Cells(k, 2).Value)
            LastRow = .Range("A" & Rows.Count).End(xlUp).Row
            .Rows(LastRow).EntireRow.Copy
            .Rows(LastRow + 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
            Sheets("TODAY").Rows(k).Copy
            .Rows(LastRow + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
        End With
    Next k
    lig = 3
    For Each ws In ThisWorkbook.Sheets 'boucle permettant de copier les 2 dernières lignes dans two last days
        If InStr("two last days,TODAY", ws.Name) = 0 And ws.Range("A3").Value <> "" Then
            LastRow = Application.Match(9 ^ 9, ws.Range("A:A"), 1) - 1
            If LastRow >= 3 Then
                ws.Rows(LastRow).Resize(3).EntireRow.Copy Destination:=Sheets("two last days").Rows(lig)
                lig = lig + 3
            End If
        End If
    Next ws
    Application.ScreenUpdating = True
End Sub

Je pense que tu devrais être plus rigoureux sur les données de tes feuilles.
Tu as ici un tuto sur les tableaux structurés

**drylanda** · 27/03/2021, 08h30

Bonsoir Anasecu. Concernant le dernier code que tu as proposé, il fonctionne parfaitement. Merci pour ton assistance et merci pour le lien sur les tableaux structurés. J'en ai déjà entamé la lecture.

**anasecu** · 27/03/2021, 08h58

Bonjour drylanda,

Merci du retour et bonne utilisation des tableaux structurés.

Ventilation de données sur plusieurs feuilles [XL-2016]

Macros et VBA Excel

Discussions similaires

Partager

Partager