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

D
  • Question
XL 2010 Identification d'une cellule cliquée
Réponses
6
Affichages
321
dadu35
D
N
  • Résolu(e)
Microsoft 365 Mot de passe pour activation macro
Réponses
4
Affichages
174
Nathan027
N
P
  • Question
Microsoft 365 TextBox avec limitation de la saisie entre 2 valeurs
Réponses
8
Affichages
60
pat66
P
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
126
GClaire
G
B
  • Résolu(e)
Microsoft 365 Besoin d'aide pour faire fonctionner 2 codes VBA ensemble
Réponses
2
Affichages
127
BenExcel
B
petitbuzuc
  • Question
XL 2016 Aide pour maj auto de la date + selection multiple dans une liste déroulante
Réponses
5
Affichages
219
fanch55
fanch55
D
  • Question
XL 2010 suppression de lignes dans un fichier EXCEL via une routine en VBA
Réponses
2
Affichages
240
mapomme
mapomme
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
203
Compte Supprimé 979
C
Messan
  • Résolu(e)
XL 2019 Organiser les données dans listbox
Réponses
2
Affichages
372
Messan
Messan
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
63
Latias
L

Membres actuellement en ligne

15 membres et 102 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
312 114
Messages
2 085 432
Membres
102 889
dernier inscrit
monsef JABBOUR