Microsoft 365 Ajouter une ligne pour deux tableaux structurés l'un à côté de l'autre

D

Diego-Andres

XLDnaute Nouveau
Bonsoir,

J'ai un petit problème dans un de mes fichiers.
Je m'explique, j'ai deux boutons l'un pour supprimer des lignes et l'autres pour ajouter des lignes.
Cela marché très bien mais j'ai ajouté des tableau structurés en plus (même nombre de ligne et emplacement que les autres et le code ne fonctionne plus :()
J'ai trouvais plusieurs solutions avec plusieurs boutons à chaque nouvelle rangée de tableau mais ça perd l'interactivité que cela avait.

Voici le code pour insérer des lignes:
VB: 
Sub Insert_Row()    'Insert a row in any else sheet

Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim Cell As Range

ActiveSheet.Unprotect ("test")

n = ActiveCell.Row

' Message d'erreur d'emplacement -------------------------------------------------------

If ActiveSheet.Name = "BUDGET_FORCAST" Then
    If n <= 8 Then
        If Sheets("HOME_PAGE").Range("F1").Value = "EN" Then
            MsgBox ("You can't insert a row at this location"), vbInformation, "Project Tracker:"
            ActiveSheet.Protect
            Exit Sub
        End If
        If Sheets("HOME_PAGE").Range("F1").Value = "FR" Then
            MsgBox ("Vous ne pouvez pas inserer une ligne a cet emplacement"), vbInformation, "Project Tracker :"
            ActiveSheet.Protect
            Exit Sub
        End If
        If Sheets("HOME_PAGE").Range("F1").Value = "ES" Then
            MsgBox ("No puedes insertar una línea en este lugar"), vbInformation, "Project Tracker :"
            ActiveSheet.Protect
            Exit Sub
        End If
    End If
End If

'Insertion --------------------------------------------------------------------------

    ActiveCell.EntireRow.Insert Shift:=xlDown
    ActiveCell.Offset(-1, 0).EntireRow.Copy Cells(ActiveCell.Row, 1)
    On Error Resume Next
    ActiveCell.EntireRow.SpecialCells(xlCellTypeConstants, xlNumbers + xlTextValues + xlLogical + xlErrors).ClearContents
    
ActiveCell.Activate
ActiveSheet.Protect Password:="test"

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

Voici celui pour supprimer:
Code: 
Sub Delete_Row()    'Erase a row in any else sheet

Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim Cell As Range

ActiveSheet.Unprotect ("test")

' Message de confirmation & suppression -----------------------------------------------------

If Sheets("HOME_PAGE").Range("F1").Value = "EN" Then
    If MsgBox("Do you really want to erase this row ?", vbYesNo, "Confirmation") = vbYes Then
        ActiveSheet.Rows(ActiveCell.Row).EntireRow.Delete
    End If
End If

If Sheets("HOME_PAGE").Range("F1").Value = "FR" Then
    If MsgBox("Voulez-vous vraiment supprimer cette ligne ?", vbYesNo, "Confirmation") = vbYes Then
        ActiveSheet.Rows(ActiveCell.Row).EntireRow.Delete
    End If
End If

If Sheets("HOME_PAGE").Range("F1").Value = "ES" Then
    If MsgBox("¿Realmente quieres borrar esa línea?", vbYesNo, "Confirmation") = vbYes Then
        ActiveSheet.Rows(ActiveCell.Row).EntireRow.Delete
    End If
End If

ActiveCell.Activate
ActiveSheet.Protect Password:="test"
    
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

J'essaie souvent de trouver des solutions mais là je bloque.
Merci de votre lecture et d'avance de votre aide
 
Trier par date Trier par votes
S

soan

XLDnaute Barbatruc
Inactif
Bonjour Diego-Andres, Claude,

Je te propose cette optimisation de ton code VBA :
VB: 
Option Explicit

Sub Insert_Row() 'Insert a row in active sheet
  Dim Cell As Range, msg$, lig&: lig = ActiveCell.Row
  If ActiveSheet.Name = "BUDGET_FORCAST" And lig <= 8 Then 'emplacement erroné
    Select Case [HOME_PAGE!F1]
      Case "EN": msg = "You can't insert a row at this location"
      Case "FR": msg = "Vous ne pouvez pas insérer une ligne à cet emplacement"
      Case "ES": msg = "No puedes insertar una línea en este lugar"
    End Select
    MsgBox msg, 64, "Project Tracker :": Exit Sub
  End If
  On Error Resume Next 'Insertion d'une ligne sur la feuille active
  ActiveSheet.Unprotect "test": Application.Calculation = -4135: Application.EnableEvents = 0
  With ActiveCell
    .EntireRow.Insert 4: .Offset(-1).EntireRow.Copy Cells(.Row, 1)
    .EntireRow.SpecialCells(2, xlNumbers + xlTextValues + xlLogical + xlErrors).ClearContents
    .Activate
  End With
  Application.EnableEvents = -1: Application.Calculation = -4105: ActiveSheet.Protect "test"
End Sub

Sub Delete_Row() 'Erase a row in active sheet
  Dim Cell As Range, msg$
  Select Case [HOME_PAGE!F1] 'Message de confirmation & suppression
    Case "EN": msg = "Do you really want to erase this row ?"
    Case "FR": msg = "Voulez-vous vraiment supprimer cette ligne ?"
    Case "ES": msg = "¿Realmente quieres borrar esa línea?"
  End Select
  If MsgBox(msg, 4, "Confirmation") <> 6 Then Exit Sub
  ActiveSheet.Unprotect "test": Application.Calculation = -4135: Application.EnableEvents = 0
  Rows(ActiveCell.Row).Delete
  Application.EnableEvents = -1: Application.Calculation = -4105: ActiveSheet.Protect "test"
End Sub
Mais pour faire ta demande, il faudrait ton fichier.
(avec quelques données non confidentielles)

soan
 
Vote positif 0 Vote négatif
D

Diego-Andres

XLDnaute Nouveau
@Pounet95 oui, ces fichiers et ces explications sur les tableaux structurés m'ont aidé beaucoup mais juste avec un tableau structuré ... pas deux qui sont l'un à côté de l'autre :).

@soan voici mon fichier c'est l'onglet "budget_forecast". Je pensais l'avoir mis en annexe ^^

Merci
Diego-Andres
 

Pièces jointes

  • 200714 IFN TEST 2022-2026V6.xlsm
    994.9 KB · Affichages: 20
Vote positif 0 Vote négatif
S

soan

XLDnaute Barbatruc
Inactif
@Diego-Andres (salut Patrick)

Je ne m'attendais pas à ce que tu m'envoies un fichier aussi compliqué, avec plein de
petits tableaux structurés ! (y'en a une flopée dans les noms définis du Gestionnaire de
noms ; pour plusieurs feuilles, y compris "BUDGET_FORCAST") ; aussi, je n'ai pas utilisé
ton fichier, et j'en ai créé un autre plus simple, pour démo (tu adapteras à ton fichier).

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

La 1ère feuille est "HOME_PAGE" ; en F1, il y a "FR" ; c'est tout pour cette feuille :
tout le reste est sur la 2ème feuille "BUDGET_FORCAST" ; sélectionne-là ; cette
feuille est protégée avec le mot de passe "test" (le même que le tien).

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

Tu peux voir qu'il y a 2 Tableaux structurés, l'un à droite de l'autre ; tous les deux
ont une ligne d'en-têtes en ligne 8 ; donc la 1ère ligne de données est la ligne 9.

Le 1er Tableau s'appelle "Tableau1" ; il a 12 lignes (de 9 à 20) ; le 2ème Tableau
s'appelle "Tableau2" ; il a 8 lignes (de 9 à 16).

C'est la colonne de la cellule active qui détermine sur lequel des 2 tableaux
les 2 macros vont agir :

* si cette colonne est < à 6, donc 1 à 5 (A à E) : ce sera sur Tableau1
* sinon : colonne >= 6 (F ou plus à droite) : ce sera sur Tableau2

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

La cellule active est A12 ; colonne A ➯ ça va être sur Tableau1 ; Ctrl d (d pour delete)
➯ message de confirmation ; si tu cliques sur "Non", ça ne fait rien (normal) ; Ctrl d ;
si tu cliques sur "Oui", ça efface la 4ème ligne du tableau : il n'y a plus "Article 4", et
rien n'a changé pour ton 2ème tableau : c'est bien indépendant.

La cellule active est toujours A12, devant "Article 5" ; fais Ctrl i (i pour insert) : ça a
ajouté une ligne vide au-dessus de "Article 5" ; il te suffit de compléter la ligne ;
là encore, le 2ème tableau est inchangé : c'est aussi indépendant.

Après exécution, la feuille est toujours protégée.

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

Sélectionne par exemple F11, devant "Article 3" ; colonne F ➯ ça sera sur Tableau2 ;
Ctrl d ; clic sur "Oui" ➯ la ligne avec "Article 3" est supprimée, sans rien changer
au Tableau1 ; Ctrl i ➯ une ligne ajoutée au-dessus de "Article 4" ; là aussi, Tableau1
est resté pareil.

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

Code VBA :
VB: 
Option Explicit

Const T1$ = "Tableau1" 'Nom du Tableau n° 1
Const T2$ = "Tableau2" 'Nom du Tableau n° 2

Sub Insert_Row() 'Insert a row in active sheet
  Dim Tbl$, msg$, dlg&, lig&, col%: lig = ActiveCell.Row
  If ActiveSheet.Name = "BUDGET_FORCAST" And lig < 9 Then 'emplacement erroné
    Select Case [HOME_PAGE!F1]
      Case "EN": msg = "You can't insert a row at this location"
      Case "FR": msg = "Vous ne pouvez pas insérer une ligne à cet emplacement"
      Case "ES": msg = "No puedes insertar una línea en este lugar"
    End Select
    MsgBox msg, 64, "Project Tracker :": Exit Sub
  End If
  ActiveSheet.Unprotect "test": Application.Calculation = -4135: Application.EnableEvents = 0
  col = ActiveCell.Column: If col < 6 Then Tbl = T1 Else Tbl = T2
  With ActiveSheet.ListObjects(Tbl)
    dlg = .ListRows.Count: If lig <= dlg + 8 Then .ListRows.Add lig - 8
  End With
  Application.EnableEvents = -1: Application.Calculation = -4105: ActiveSheet.Protect "test"
End Sub

Sub Delete_Row() 'Erase a row in active sheet
  Dim Tbl$, msg$, dlg&, lig&, col%: lig = ActiveCell.Row
  Select Case [HOME_PAGE!F1] 'Message de confirmation & suppression
    Case "EN": msg = "Do you really want to erase this row ?"
    Case "FR": msg = "Voulez-vous vraiment supprimer cette ligne ?"
    Case "ES": msg = "¿Realmente quieres borrar esa línea?"
  End Select
  If MsgBox(msg, 4, "Confirmation") <> 6 Then Exit Sub
  ActiveSheet.Unprotect "test": Application.Calculation = -4135: Application.EnableEvents = 0
  col = ActiveCell.Column: If col < 6 Then Tbl = T1 Else Tbl = T2
  With ActiveSheet.ListObjects(Tbl)
    dlg = .ListRows.Count: If lig <= dlg + 8 Then .ListRows(lig - 8).Delete
  End With
  Application.EnableEvents = -1: Application.Calculation = -4105: ActiveSheet.Protect "test"
End Sub
--------------------------------------------------

Maintenant, il te faut juste adapter tout ça à tous tes mini-tableaux structurés ;
bon courage ! :p (surtout, ne me demande pas de le faire à ta place !)

soan
 

Pièces jointes

  • Exo Diego-Andres.xlsm
    21.1 KB · Affichages: 3
Dernière édition:
Vote positif 0 Vote négatif
S

soan

XLDnaute Barbatruc
Inactif
Je crois qu'il a voulu tester la suite de Fibonacci avec des TS ;
tu sais, l'exo avec des lapins : 1 1 2 3 5 8 13 21 34 55 89 ...
Image.JPG

soan
 
Vote positif 0 Vote négatif

Discussions similaires

E
  • Résolu(e)
XL 2019 transfer listbox vers une colonne à partir de la 4 ligne
Réponses
2
Affichages
108
escudo
E
D
  • Question
XL 2010 Identification d'une cellule cliquée
Réponses
6
Affichages
569
dadu35
D
N
  • Résolu(e)
XL 2021 comment faire recherche dans une colonne et ligne
Réponses
5
Affichages
307
job75
job75
Amigo
  • Question
XL 2016 Protéger Plage avec condition
2
Réponses
16
Affichages
853
Amigo
Amigo
G
  • Question
Microsoft 365 Export données
Réponses
4
Affichages
419
GClaire
G
L
  • Question
Microsoft 365 Faire agir une macro en fonction de l'emplacement du bouton
Réponses
2
Affichages
296
AtTheOne
AtTheOne
E
  • Question
Microsoft 365 Listbox avec plus de 10 colonnes
Réponses
6
Affichages
371
Excellearning
E
AlCapone
  • Résolu(e)
Microsoft 365 VBA - BeforeDoubleClick, 1ère cellule vide à partir de cellule active pour insertion de ligne
Réponses
4
Affichages
117
AlCapone
AlCapone
N
  • Résolu(e)
Microsoft 365 Mot de passe pour activation macro
Réponses
4
Affichages
344
Nathan027
N
B
  • Résolu(e)
Microsoft 365 creation d'liste à imprimer
2 3 4
Réponses
51
Affichages
1 K
Banbara
B

Membres actuellement en ligne

14 membres et 256 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 656
Messages
2 111 610
Membres
111 221
dernier inscrit
Odré