XL 2016 ventiler les informations dans les bonnes feuilles du classeur

[Ernesta]

bonsoir à tous les cracks!
j'ai besoin d'aide pour terminer un travail sur Excel. j'ai travaillé sur le code suivant mais je reçois un message d'erreur concernant la méthode delete de la classe range :

Dim j As Integer
Dim lastrow As Integer

Sub ventilation()

Application.ScreenUpdating = False


'Boucle permettant de lire toutes les 6 feuilles du classeur
For j = 1 To 6
Sheets(j).Select
lastrow = Range("E1000000").End(xlUp).Row
For i = lastrow To 8 Step -1 'parcourir les lignes en remontant vers le haut
Sheets(j).Select
Rows(i).Select
Selection.Delete shift:=xlUp
Next i

Sheets("BD").Select
derniereligne = Range("E1000000").End(xlUp).Row

For k = 8 To derniereligne
Sheets("BD").Select
If Sheets(j).Name = Cells(k, 16).Value Then

Rows(k).Select
Selection.Copy

Sheets(j).Select
lastrow = Range("E1000000").End(xlUp).Row + 1
Cells(lastrow, 1).Select
ActiveSheet.Paste
End If

Next k

Next j
Sheets("BD").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[Ernesta]

@Ernesta

ton fichier en retour ; fais Ctrl e ; ou clique sur le bouton Ventilation.

Option Explicit

Private Sub Job(i As Byte)
  Dim cel As Range, dlg&, lig&, col%
  With Worksheets(i)
    .Rows("9:" & Rows.Count).Delete 'supprime toutes les lignes sous la ligne 8
    .Rows(8).ClearContents 'efface toutes les cellules de la ligne 8
    dlg = ActiveSheet.ListObjects("suividestextes3456").ListRows.Count
    For lig = 8 To dlg + 7
      .Rows(lig).RowHeight = Rows(lig).RowHeight
      For col = 5 To 20
        Set cel = Cells(lig, col)
        If cel <> "" Then .Cells(lig, col) = cel
      Next col
    Next lig
  End With
End Sub

Sub ventilation()
  Dim i As Byte
  Application.ScreenUpdating = 0
  Worksheets("Source").Select
  For i = 1 To 6: Job i: Next i
  MsgBox "Copie effectuée."
End Sub

soan

je retrouve la même copie sur toutes les feuilles

 

[soan]

@Ernesta

j'ai dû m'absenter, et j'viens d'lire ton post ; effectivement, j'avais pas bien compris
ton exo, car dans ton post #9, tu as oublié d'indiquer clairement c'qu'il faut faire !

tu aurais dû écrire : « il faut ventiler les lignes de données du tableau de la feuille
"Source" sur les autres feuilles, selon l'année de la colonne T, lorsqu'elle est égale
à l'année du nom de l'onglet d'une feuille de destination. » ; sitôt que j'ai bien
compris ceci, j'ai modifié la macro en conséquence ; maintenant : la 1ère ligne
de "Source" est copiée en feuille "2020", la 2ème ligne en feuille "2015" ; toutes
les autres feuilles sont inchangées ; si tu avais mis plus de données, avec une
année pour chaque feuille, alors "2016" à "2019" n'auraient pas été vides.

après la copie des données, la feuille "Source" est inchangée ; mais peut-être
préfères-tu qu'on efface les données source qui ont été copiées ?
➯ le tableau de la feuille "Source" sera vide en fin d'exécution de la macro.

nouveau code VBA (bien différent du précédent) :

Option Explicit

Dim ws As Worksheet, dlg&

Private Sub Job(i As Byte)
  Dim An%, lg1&, lg2&, col%
  Worksheets(i).Select
  Rows("9:" & Rows.Count).Delete 'supprime toutes les lignes sous la ligne 8
  Rows(8).ClearContents 'efface toutes les cellules de la ligne 8
  An = Val(ActiveSheet.Name): lg2 = 8
  For lg1 = 8 To dlg + 7
    If ws.Cells(lg1, 20) = An Then
      Rows(lg2).RowHeight = ws.Rows(lg1).RowHeight
      ws.Cells(lg1, 5).Resize(, 16).Copy
      Cells(lg2, 5).PasteSpecial -4163
      lg2 = lg2 + 1
    End If
  Next lg1
  [F8].Select
End Sub

Sub ventilation()
  Dim i As Byte
  Application.ScreenUpdating = 0: Set ws = Worksheets("Source")
  dlg = ws.ListObjects("suividestextes3456").ListRows.Count
  For i = 1 To 6: Job i: Next i: Application.CutCopyMode = 0
  ws.Select: MsgBox "Ventilation effectuée."
End Sub

à te lire pour avoir ton avis ; si tu veux un complément, comme l'effacement
des données sources, n'hésite pas à demander.

soan

 

[job75]

Avec le filtre automatique les tableaux structurés sont gênants, je les ai tous convertis en plages.

Bon on peut conserver tous les tableaux structurés, voyez ce fichier (2) et la macro :

Sub Ventilation()
Dim d As Object, w As Worksheet, P As Range, i&, x$, Q As Range
Application.ScreenUpdating = False
With Sheets("Source")
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = vbTextCompare 'la casse est ignorée
    For Each w In Worksheets
        If w.Name <> .Name Then d(w.Name) = "" 'liste des feuilles
    Next w
    Set P = .ListObjects(1).Range 'tableau structuré
End With
For i = 2 To P.Rows.Count
    x = CStr(P(i, 16))
    If d.exists(x) Then
        With Sheets(x)
            Set Q = .ListObjects(1).Range 'tableau structuré
            If Q.Rows.Count > 2 Then Q.Rows(3).Resize(Q.Rows.Count - 2).Delete xlUp
            P.AutoFilter 16, x 'filtre automatique
            P.Rows(2).Resize(P.Rows.Count - 1).Copy Q(2, 1)
            P.AutoFilter
            .Rows.AutoFit 'ajustement hauteur
        End With
        d.Remove x 'on retire l'item puisqu'il a été traité
    End If
Next i
End Sub

 

[soan]

@Ernesta

j'ai lu plus attentivement ton post #11 ; j'ai vu que tu as écrit : « alimenter des données
dans chacune des feuilles et effacer ces informations du fichier source pour ne garder
que celles dont les critères de ventilation ne sont pas remplis ».

aussi, je te propose une autre version du fichier Excel, où les données copiées sont ensuite
supprimées du tableau de la feuille "Source" ➯ après exécution de la macro, le tableau
de feuille "Source" est vide ; mais si tu avais mis plus de données représentatives d'un
cas réel, il serait resté les lignes non ventilées (car l'année de la cellule T n'est égale à
aucune année des noms d'onglets des autres feuilles).

regarde quand même le fichier Excel de mon post #17, car la comparaison des 2 codes
VBA te montrera les différences selon que les lignes sources sont effacées ou non.

Option Explicit

Dim ws As Worksheet, dlg&

Private Sub Job(i As Byte)
  Dim An%, lg1&, lg2&, col%
  Worksheets(i).Select
  Rows("9:" & Rows.Count).Delete 'supprime toutes les lignes sous la ligne 8
  Rows(8).ClearContents 'efface toutes les cellules de la ligne 8
  An = Val(ActiveSheet.Name): lg2 = 8
  For lg1 = dlg + 7 To 8 Step -1
    If ws.Cells(lg1, 20) = An Then
      Rows(lg2).RowHeight = ws.Rows(lg1).RowHeight
      ws.Cells(lg1, 5).Resize(, 16).Copy
      Cells(lg2, 5).PasteSpecial -4163
      lg2 = lg2 + 1
      ws.ListObjects("suividestextes3456").ListRows(lg1 - 7).Delete
    End If
  Next lg1
  [F8].Select
End Sub

Sub ventilation()
  Dim i As Byte
  Application.ScreenUpdating = 0: Set ws = Worksheets("Source")
  dlg = ws.ListObjects("suividestextes3456").ListRows.Count
  For i = 1 To 6: Job i: Next i: Application.CutCopyMode = 0
  ws.Select: Application.ScreenUpdating = -1
  MsgBox "Ventilation effectuée."
End Sub

je pense que cette fois, cette version devrait être OK ;
si oui, merci de bien vouloir le confirmer ; sinon,
indique-moi quelle adaptation tu aimerais.

soan

 

[job75]

Une solution très simple avec cette macro dans ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not Sh.Name Like "####" Then Exit Sub
Dim P As Range, Q As Range
Set P = Sheets("Source").ListObjects(1).Range 'tableau structuré
Set Q = Sh.ListObjects(1).Range 'tableau structuré
Application.ScreenUpdating = False
If Q.Rows.Count > 2 Then Q.Rows(3).Resize(Q.Rows.Count - 2).Delete xlUp
Q.Rows(2) = ""
If Application.CountIf(P.Columns(16), Sh.Name) = 0 Then Exit Sub
P.AutoFilter 16, Sh.Name 'filtre automatique
P.Rows(2).Resize(P.Rows.Count - 1).Copy Q(2, 1)
P.AutoFilter
Sh.Rows.AutoFit 'ajustement hauteur
End Sub

Il n'y a plus de boucle, la macro se déclenche quand on active une feuille, fichier (3).

 

[Ernesta]

excellent travail aux deux cracks soan et job75 qui ont eu la bonne lecture de ce que je recherche pour ce projet.
toutes ma gratitude à l'ensemble du forum. je revient sous peu pour élargir mes connaissances en VBA.

 

[Ernesta]

Une solution très simple avec cette macro dans ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not Sh.Name Like "####" Then Exit Sub
Dim P As Range, Q As Range
Set P = Sheets("Source").ListObjects(1).Range 'tableau structuré
Set Q = Sh.ListObjects(1).Range 'tableau structuré
Application.ScreenUpdating = False
If Q.Rows.Count > 2 Then Q.Rows(3).Resize(Q.Rows.Count - 2).Delete xlUp
Q.Rows(2) = ""
If Application.CountIf(P.Columns(16), Sh.Name) = 0 Then Exit Sub
P.AutoFilter 16, Sh.Name 'filtre automatique
P.Rows(2).Resize(P.Rows.Count - 1).Copy Q(2, 1)
P.AutoFilter
Sh.Rows.AutoFit 'ajustement hauteur
End Sub

Il n'y a plus de boucle, la macro se déclenche quand on active une feuille, fichier (3).

j'explore les possibilités de travail avec ce modèle merci pour votre aide très précieuse!

 

[Ernesta]

Une solution très simple avec cette macro dans ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not Sh.Name Like "####" Then Exit Sub
Dim P As Range, Q As Range
Set P = Sheets("Source").ListObjects(1).Range 'tableau structuré
Set Q = Sh.ListObjects(1).Range 'tableau structuré
Application.ScreenUpdating = False
If Q.Rows.Count > 2 Then Q.Rows(3).Resize(Q.Rows.Count - 2).Delete xlUp
Q.Rows(2) = ""
If Application.CountIf(P.Columns(16), Sh.Name) = 0 Then Exit Sub
P.AutoFilter 16, Sh.Name 'filtre automatique
P.Rows(2).Resize(P.Rows.Count - 1).Copy Q(2, 1)
P.AutoFilter
Sh.Rows.AutoFit 'ajustement hauteur
End Sub

Il n'y a plus de boucle, la macro se déclenche quand on active une feuille, fichier (3).

je suis impressionné pas besoin d'un bouton pour la ventilation des données. tout se fait systématiquement. comment peut-on combiner cette macro avec les avancées de soan que je trouve particulièrement innovante dans la suite de l'exploitation des données du classeur qui pourrait me conduire à un tableau de bord qui ressort la situation des textes pour les six années.

merci pour cette marque d'attention!

 

[Ernesta]

je voudrai aussi incrémenter un identifiant unique pour chaque texte.

 

[job75]

Vous faites ce que vous voulez mais comprenez bien que le filtre automatique évite une boucle.

Quant à ceci :

je voudrai aussi incrémenter un identifiant unique pour chaque texte.

c'est un autre problème, nombreux exemples sur XLD.

Bonne nuit.

 

[Ernesta]

Vous faites ce que vous voulez mais comprenez bien que le filtre automatique évite une boucle.

Quant à ceci :

c'est un autre problème, nombreux exemples sur XLD.

Bonne nuit.

c'est très aimable de votre part, merci!

 

[soan]

Bonjour job75, Ernesta,

j'viens d'lire ton post #20 ; ta solution avec utilisation du filtre pour la colonne T,
sur le critère Année du nom de la feuille, et qui évite une boucle, est vraiment
très élégante ! bravo !!!

soan

 

[soan]

@Ernesta

dans ton post #23, tu as écrit :

« comment peut-on combiner cette macro avec les avancées de soan ? »

si j'ai bien compris, tu veux pouvoir utiliser la solution de job75, qui est pour une feuille
active Année, et aussi ma solution avec boucle, qui est pour les six feuilles d'un coup ;
si c'est ça, alors il s'agit d'éviter que la macro de job75 se déclenche lorsque ma sub va
sur une feuille de destination ; à propos, j'ai dû sélectionner la feuille de destination
pour sélectionner F8, afin d'enlever la sélection du .PasteSpecial ; essaye en modifiant
comme suit le début de la sub job75() de la sub Job() :

Private Sub Job(i As Byte)
  Dim An%, lg1&, lg2&, col%
  Application.EnableEvents = 0
  Worksheets(i).Select
  Application.EnableEvents = -1

j'ai ajouté seulement les 2 lignes qui sont avant et après Worksheets(i).Select
j'espère que ça marchera ; je n'ai pas testé ; à toi l'honneur de faire les crashs-tests !

si les événements d'Excel ne sont pas correctement désactivés, je crois que si tu éteins le PC,
ça va le faire ! (non, ne le fais surtout pas !!! c'est une blague !!! )

soan

 

[soan]

Lis d'abord mes 2 posts #27 et #28

sur ton post #24 : « je voudrai aussi incrémenter un identifiant unique pour chaque texte. »

s'il s'agit simplement d'avoir un ID de 1, 2, 3, 4, etc... pour chaque ligne, alors sur la feuille
"Source", met cette formule en E8 : =N(E7)+1 ; ma macro ventilation() le copiera aussi,
sans que tu doives changer le code VBA, car j'avais mis :

ws.Cells(lg1, 5).Resize(, 16).Copy ➯ c'est à partir de la colonne E, jusqu'à la colonne T

---------------------------------------------------------------------------------------------------

s'il s'agit d'autre chose, précise mieux ce que tu veux, et de quel texte tu parles.

est-ce par rapport à la colonne I « INTITULE DU TEXTE » ? et tu voudrais un
n° unique pour chaque « Bonjour » puis un n° unique pour chaque « salut » ?

si c'est ça, tu dois indiquer une liste exhaustive de tous les textes qu'on peut trouver
dans cette colonne, et même avec ça, c'est pas sûr que ce sera évident, si les textes
sont trop nombreux et / ou trop similaires !

éventuellement, envisager de mettre cette liste exhaustive sur une autre feuille,
avec 2 colonnes n° / texte ; ensuite, sur la feuille "Source", saisir le n° unique
chaque fois qu'on a besoin du texte correspondant ; un simple RECHERCHEV()
pourra le récupérer.

comme ça sera pas évident de s'rappeler du n° unique pour chaque texte,
prévoir une validation de données avec liste ... mais si la liste est trop
longue, ça va pas être pratique pour faire défiler et choisir le bon item !

soan

 

[job75]

Bonjour Ernesta, soan, le forum,

je voudrai aussi incrémenter un identifiant unique pour chaque texte.

Bien que ce soit hors sujet voyez le fichier joint et cette macro :

Private Sub Worksheet_Change(ByVal Target As Range)
With ListObjects(1).Range.Columns(1)
    Application.EnableEvents = False
    If Not Intersect(Target, .Cells) Is Nothing Then Application.Undo 'annule les modifications manuelles en 1ère colonne
    If Application.CountBlank(.Cells) Then
        For Each Target In .Cells.SpecialCells(xlCellTypeBlanks)
            Target = Application.Max(.Cells) + 1
        Next
    End If
    Application.EnableEvents = True
End With
End Sub

L'ID s'incrémente automatiquement quand le tableau s'agrandit, la colonne E ne peut pas être modifiée manuellement.

A+