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

 

[job75]

Bonsoir Ernesta,

En VBA il faut éviter les Select, ainsi que les boucles imbriquées, testez plutôt cette macro :

Sub Ventilation()
Dim d As Object, w As Worksheet, P As Range, i&, x$
Application.ScreenUpdating = False
With Sheets("BD")
    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
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    Set P = .Range(.Cells(7, 16), .Cells(.Rows.Count, 16).End(xlUp))
End With
For i = 2 To P.Count
    x = CStr(P(i))
    If d.exists(x) Then
        With Sheets(x)
            .Rows("8:" & .Rows.Count).Delete 'RAZ
            P.AutoFilter 1, x 'filtre automatique
            P.EntireRow.Copy .Range("A8")
            .Rows(8).Delete 'ligne des titres
            P.AutoFilter
        End With
        d.Remove x 'on retire l'item puisqu'il a été traité
    End If
Next i
End Sub

Bonne nuit.

 

[soan]

Bonjour @Ernesta, job75,

Je propose cette optimisation de ton code VBA :

Option Explicit

Sub ventilation()
  Dim sh%, nlm&, cel As Range, dl1&, dl2&, lg1&, lg2&
  nlm = Rows.Count: Application.ScreenUpdating = 0
  dl1 = Worksheets("BD").Cells(nlm, 5).End(3).Row
  For sh = 1 To 6 'pour les 6 feuilles du classeur
    Worksheets(sh).Select: dl2 = Cells(nlm, 5).End(3).Row
    For lg2 = dl2 To 8 Step -1 'de bas en haut
      'Rows(lg2).Delete 'tu as oublié une condition ! car ça supprime toutes les lignes !!!
    Next lg2 'normalement, ça devrait être, par exemple : supprimer la ligne si telle cellule
    'de la ligne est vide ; ou si telle cellule de la ligne contient telle ou telle valeur.
    For lg1 = 8 To dl1
      Set cel = Worksheets("BD").Cells(lg1, 16)
      If cel = ActiveSheet.Name Then
        lg2 = Cells(nlm, 5).End(3).Row + 1: Cells(lg2, 1).Select
        cel.EntireRow.Copy: ActiveSheet.Paste
      End If
    Next lg1
  Next sh
  Application.CutCopyMode = 0: Worksheets("BD").Select
End Sub

à te lire pour avoir ton avis.

soan

 

[soan]

@Ernesta

ajout : perso, j'aurais pu faire mieux si tu avais joint ton fichier, car au lieu de
copier/coller une ligne entière, j'aurais fait un copier/coller de telle colonne
à telle colonne ; non plus via ActiveSheet.Paste (qui oblige à sélectionner au
préalable la cellule de destination, donc à sélectionner aussi la feuille de
destination), mais via .PasteSpecial ➯ inutile de sélectionner la cellule de
destination, ni la feuille de destination ➯ on écrit directement sur la feuille,
sans devoir la sélectionner, et la gestion des feuilles peut être simplifiée !

voilà c'qui arrive quand un demandeur indique juste un code VBA
sans joindre un fichier exemple !

soan

 

[job75]

Bonjour Ernesta, soan, le forum,

'tu as oublié une condition ! car ça supprime toutes les lignes !!!

Il faut supprimer toutes les lignes à partir de la ligne 8 avant de recopier celles qu'on ventile.

C'est pour ça que dans ma macro il y a :

.Rows("8:" & .Rows.Count).Delete 'RAZ

A+

 

[soan]

Bonjour job75,

non, dans la macro initiale du demandeur, il n'y a pas :

.Rows("8:" & .Rows.Count).Delete 'RAZ

il y a :

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

soan

 

[job75]

Allons allons, notre ami fait une boucle car il ne sait pas qu'on peut tout supprimer d'un coup.

 

[soan]

bon, ben s'il faut vraiment supprimer toutes les lignes
avant d'faire la ventilation, soit !

soan

 

[Ernesta]

Bonjour à tous mes cracks!
j'apprécie beaucoup le travail et l'attention que vous portez à chacun de nous sur ce forum et je vous souhaite une bonne continuation.

je n'ai pas une très grande maitrise du VBA je m'appuie sur du tuto des chaines youtube pour réaliser certains projets.
je vais pour cela vous transmettre le fichier afin de mieux réaliser la ventilation sur les bonnes feuilles du classeur.
cordialement

 

[Ernesta]

Selection.Delete shift:=xlUp

cette ligne est marqué en jaune et toutes feuilles sont vides mais la macro ne copie aucune donnée dans les feuilles.

 

[Ernesta]

j'ai essayé ce code sur mon classeur mais rien de se produit. pourtant il semble cadrer avec l'esprit de ce que je recherche dans ce projet. c'est à dire parvenir à alimenter des données dans chacune des feuilles et effacer ces information du fichier source pour ne garder que celles dont les critères de ventilation ne sont pas remplis pour ce faire prévoir un bouton "mise à jour" pour exécuter la macro.
cordialement

Sub Ventilation()
Dim d As Object, w As Worksheet, P As Range, i&, x$
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
If .FilterMode Then .ShowAllData 'si la feuille est filtrée
Set P = .Range(.Cells(7, 16), .Cells(.Rows.Count, 16).End(xlUp))
End With
For i = 2 To P.Count
x = CStr(P(i))
If d.exists(x) Then
With Sheets(x)
.Rows("8:" & .Rows.Count).Delete 'RAZ
P.AutoFilter 1, x 'filtre automatique
P.EntireRow.Copy .Range("A8")
.Rows(8).Delete 'ligne des titres
P.AutoFilter
End With
d.Remove x 'on retire l'item puisqu'il a été traité
End If
Next i
End Sub

 

[job75]

Bonjour Ernesta,

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

Voyez le fichier joint et la macro adaptée :

Sub Ventilation()
Dim d As Object, w As Worksheet, P As Range, i&, x$
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
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    Set P = .Range(.Cells(7, 20), .Cells(.Rows.Count, 20).End(xlUp))
End With
For i = 2 To P.Rows.Count
    x = CStr(P(i))
    If d.exists(x) Then
        With Sheets(x)
            .Rows("8:" & .Rows.Count).Delete 'RAZ
            P.AutoFilter 1, x 'filtre automatique
            P.EntireRow.Copy .Range("A8")
            .Rows(8).Delete 'ligne des titres
            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

A+

 

[Ernesta]

la ventilation des données sur les feuilles du classeur se fait correctement
pour ma gouverne je voudrai comprendre ce que signifie:

If .FilterMode Then .ShowAllData 'si la feuille est filtrée
Set P = .Range(.Cells(7, 20), .Cells(.Rows.Count, 20).End(xlUp))
End With

merci cordialement mon crack votre macro s'exécute parfaitement.

 

[soan]

@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

 

[Ernesta]

les inconvénients dans cette macro le tableau de la feuille source ne donne plus de nouvelles lignes. et lorsqu'une informations est modifier sur le tableau source par exemple une modification de date 20 sept 20 que nous avons activer le bouton donne l'écriture s'est logé dans la feuille 2020 si cette date est rectifier par 20 sept 2017 l'écriture de la ligne apparaitra dans les deux feuilles pourtant dans la feuille source il n'y a qu'une seule date désormais pris en compte celle de 2017.

comment faire pour rafraichir les feuilles pour les mettre à jour à chaque ventilation?

vous avez toute ma gratitude !