XL 2016 ventiler les informations dans les bonnes feuilles du classeur

Ernesta · 21 Octobre 2020

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 · 23 Octobre 2020

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 :

VB:

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 · 23 Octobre 2020

job75 à dit:
Bonjour Ernesta, soan, le forum,

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

VB:

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

XL 2016 ventiler les informations dans les bonnes feuilles du classeur

Ernesta

XLDnaute Nouveau

job75

XLDnaute Barbatruc

Pièces jointes

Ernesta

XLDnaute Nouveau

Discussions similaires