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]

On remarquera qu'avec la solution précédente l'ajout ou la suppression de lignes est impossible.

Pour y remédier voyez ce fichier (2) et la macro complétée :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim n&, a As Application
With ListObjects(1).Range.Columns(1)
    n = .Cells.Count 'mémorise le nombre de lignes
    Set a = Application
    a.EnableEvents = False
    If Not Intersect(Target, .Cells) Is Nothing Then a.Undo: If .Cells.Count <> n Then a.Undo
    If a.CountBlank(.Cells) Then
        For Each Target In .Cells.SpecialCells(xlCellTypeBlanks)
            Target = a.Max(.Cells) + 1
        Next
    End If
    a.EnableEvents = True
End With
End Sub

 

[Ernesta]

Bonjour Ernesta, soan, le forum,

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+

excellent merci ! ça fonctionne très bien