Microsoft 365 Macro insérer des lignes en fonction du contenu d'une cellule

G

Guileo

XLDnaute Nouveau
Bonjour à tous,

Dans le cadre d'un projet perso, j'ai besoin d'une macro qui agit sur un tableau que j'obtiens avec un export de logiciel.

Le but est le suivant :
Si l'une des cases contient un remplissage "vert" alors il faut ajouter une colonne puis dans cette colonne renseigner l'information correspondante à la case verte.

J'ai expliqué en détail dans le fichier excel ci-joint.

J'ai essayée des choses mais je suis trop novice pour réussir ...

Pouvez-vous me donner votre avis de macro d'expert pour ce sujet :)

Très bonne journée à vous.
Guil
 

Pièces jointes

  • Test macro.xlsx
    21.5 KB · Affichages: 22
Trier par date Trier par votes
R

Rouge

XLDnaute Impliqué
Bonjour,

L'énoncé de votre problème n'est pas très clair, d'où sûrement le manque de réponses.
Vous écrivez:
-qu'il faut ajouter une colonne entre I et J si on trouve une cellule verte dans le tableau de AK à AP,
-idem pour la première cellule verte s'il y en a plusieurs sauf que vous ne précisez pas si c'est sur une même ligne ou sur l'ensemble du tableau de la plage AK à AP, et pour les autres cellules vertes on ajoute une ligne en fin de tableau .
Ce que je vois, c'est que dans tous les cas il faut insérer une colonne entre I et J, donc autant qu'elle soit créée d'emblée. De par cette insertion, la nouvelle colonne prendra la position de la colonne J et la colonne J actuelle passera en colonne K, ce qui décalera tout le reste d'un cran vers la droite et le tableau qui était en AK:AP se retrouvera en AL:AQ.

Questions:
-Lorsque tout sera réalisé comme vous le souhaitez que fait-on des cellules vertes, faut-il supprimer la couleur, ou bien cela sera écrasé par un nouvel import de données?
-Lors de votre prochain import de données, que faudra-t-il faire? Insérer encore une colonne supplémentaire?

Cdlt
 
Vote positif 0 Vote négatif
R

Rouge

XLDnaute Impliqué
Votre macro modifiée
VB: 
Sub Bouton1_Cliquer()
    Dim n As Long, Coul As Long, l As Long, k As Long
    Application.ScreenUpdating = False
    n = Range("CB1").Value
    Coul = Range("CB1").Interior.Color
    l = Range("CB2").Value
    k = n + l + 2
    For i = l To n + l
        If Range("AT" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AT3").Value
            Range("A" & k & ":AT" & k).Value = Range("A" & i & ":AT" & i).Value
            Range("AT" & k).Interior.Color = Coul
            k = k + 1
        End If
        If Range("AU" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AU3").Value
            Range("A" & k & ":AU" & k).Value = Range("A" & i & ":AU" & i).Value
            Range("AU" & k).Interior.Color = Coul
            k = k + 1
        End If
        If Range("AV" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AV3").Value
            Range("A" & k & ":AV" & k).Value = Range("A" & i & ":AV" & i).Value
            Range("AV" & k).Interior.Color = Coul
            k = k + 1
        End If
        If Range("AW" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AW3").Value
            Range("A" & k & ":AW" & k).Value = Range("A" & i & ":AW" & i).Value
            Range("AW" & k).Interior.Color = Coul
            k = k + 1
        End If
        If Range("AX" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AX3").Value
            Range("A" & k & ":AX" & k).Value = Range("A" & i & ":AX" & i).Value
            Range("AX" & k).Interior.Color = Coul
            k = k + 1
        End If
        If Range("AY" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AY3").Value
            Range("A" & k & ":AY" & k).Value = Range("A" & i & ":AY" & i).Value
            Range("AY" & k).Interior.Color = Coul
            k = k + 1
        End If
    Next
End Sub

Cdlt
 
Vote positif 0 Vote négatif
S

soan

XLDnaute Barbatruc
Inactif
Bonjour Guileo, Rouge, job75,

ton fichier en retour ; fais Ctrl e ➯ travail effectué :

ça a ajouté 3 colonnes devant l'ancienne colonne J pour David, Louise, et Simon.

➯ maintenant, la colonne "Désignation" se retrouve en colonne M. 😊


code VBA de Module1 (49 lignes) :

VB: 
Option Explicit

Const cf& = 5287936 'couleur de fond : vert foncé

Dim nci% 'n° col devant laquelle insérer 1 col ; au départ : J = 10
Dim ncv% 'n° colonne à vérifier ; au départ, pour la colonne AK : 37
Dim ncf As Byte 'nombre de colonnes faites ; au départ : 0 colonne
Dim dlg& 'dernière ligne utilisée ; ce sera selon la colonne A

Private Sub Job() 'pour traiter chaque colonne l'une après l'autre,
                  'à partir de la colonne cdL / ncv : AK / 37
  Dim k&, n&, i&
  For i = 7 To dlg
    If Cells(i, ncv).Interior.Color = cf Then
      n = n + 1 'nb de cellules de fond cf dans la colonne ncv
      If n = 1 Then 'pour la 1ère cellule de fond cf
        Columns(nci).Insert 2, 0: nci = nci + 1: ncv = ncv + 1
        k = nci - 1
        With Cells(4, k)
          .Borders(9).Color = 12566463: .Borders(9).LineStyle = 1
          With .Offset(-1).Resize(5)
            .Borders(10).Color = 12566463: .Borders(10).LineStyle = 1
            .Borders(7).Color = 12566463: .Borders(7).LineStyle = 1
          End With
          With .Offset(1).Resize(4).Borders(12)
            .Color = 12566463: .LineStyle = 1: .Weight = 1
          End With
          .Value = Cells(3, ncv)
        End With
      End If
      With Cells(i, k)
        .HorizontalAlignment = 4: .IndentLevel = 1
        .NumberFormat = "#,##0.0000;-#,##0.0000;"
        .Value = Cells(i, ncv)
      End With
    End If
  Next i
  ncf = ncf + 1: ncv = ncv + 1
End Sub

Sub Essai()
  Const cdL$ = "AK" 'colonne de départ en Lettres : AK
  Const nct As Byte = 6 'nombre de colonnes à traiter : 6 (de AK à AP)
  nci = 10 'n° col devant laquelle insérer 1 col ; au départ : J = 10
  ncv = Columns(cdL).Column: dlg = Cells(Rows.Count, 1).End(3).Row
  Application.ScreenUpdating = 0: ncf = 0
  Do: Job: Loop Until ncf = nct
End Sub

si besoin, tu peux demander une adaptation.
à te lire pour avoir ton avis. ;)

soan
 

Pièces jointes

  • Test macro.xlsm
    27.7 KB · Affichages: 6
Vote positif 0 Vote négatif
G

Guileo

XLDnaute Nouveau
soan à dit:
Bonjour Guileo, Rouge, job75,

ton fichier en retour ; fais Ctrl e ➯ travail effectué :

ça a ajouté 3 colonnes devant l'ancienne colonne J pour David, Louise, et Simon.

➯ maintenant, la colonne "Désignation" se retrouve en colonne M. 😊


code VBA de Module1 (49 lignes) :

VB: 
Option Explicit

Const cf& = 5287936 'couleur de fond : vert foncé

Dim nci% 'n° col devant laquelle insérer 1 col ; au départ : J = 10
Dim ncv% 'n° colonne à vérifier ; au départ, pour la colonne AK : 37
Dim ncf As Byte 'nombre de colonnes faites ; au départ : 0 colonne
Dim dlg& 'dernière ligne utilisée ; ce sera selon la colonne A

Private Sub Job() 'pour traiter chaque colonne l'une après l'autre,
                  'à partir de la colonne cdL / ncv : AK / 37
  Dim k&, n&, i&
  For i = 7 To dlg
    If Cells(i, ncv).Interior.Color = cf Then
      n = n + 1 'nb de cellules de fond cf dans la colonne ncv
      If n = 1 Then 'pour la 1ère cellule de fond cf
        Columns(nci).Insert 2, 0: nci = nci + 1: ncv = ncv + 1
        k = nci - 1
        With Cells(4, k)
          .Borders(9).Color = 12566463: .Borders(9).LineStyle = 1
          With .Offset(-1).Resize(5)
            .Borders(10).Color = 12566463: .Borders(10).LineStyle = 1
            .Borders(7).Color = 12566463: .Borders(7).LineStyle = 1
          End With
          With .Offset(1).Resize(4).Borders(12)
            .Color = 12566463: .LineStyle = 1: .Weight = 1
          End With
          .Value = Cells(3, ncv)
        End With
      End If
      With Cells(i, k)
        .HorizontalAlignment = 4: .IndentLevel = 1
        .NumberFormat = "#,##0.0000;-#,##0.0000;"
        .Value = Cells(i, ncv)
      End With
    End If
  Next i
  ncf = ncf + 1: ncv = ncv + 1
End Sub

Sub Essai()
  Const cdL$ = "AK" 'colonne de départ en Lettres : AK
  Const nct As Byte = 6 'nombre de colonnes à traiter : 6 (de AK à AP)
  nci = 10 'n° col devant laquelle insérer 1 col ; au départ : J = 10
  ncv = Columns(cdL).Column: dlg = Cells(Rows.Count, 1).End(3).Row
  Application.ScreenUpdating = 0: ncf = 0
  Do: Job: Loop Until ncf = nct
End Sub

si besoin, tu peux demander une adaptation.
à te lire pour avoir ton avis. ;)

soan
Cliquez pour agrandir...
Bonjour Soan,

Merci beaucoup pour ton retour à ma problématique.
Je suis désolé j'ai été absent ces derniers temps.
Elle fonctionne très bien et je vais l'utiliser merci.

C'est cool d'avoir de l'aide des membres de ce site :) !!!!
A très bientôt
Guil
 
Vote positif 0 Vote négatif
G

Guileo

XLDnaute Nouveau
Rouge à dit:
Votre macro modifiée
VB: 
Sub Bouton1_Cliquer()
    Dim n As Long, Coul As Long, l As Long, k As Long
    Application.ScreenUpdating = False
    n = Range("CB1").Value
    Coul = Range("CB1").Interior.Color
    l = Range("CB2").Value
    k = n + l + 2
    For i = l To n + l
        If Range("AT" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AT3").Value
            Range("A" & k & ":AT" & k).Value = Range("A" & i & ":AT" & i).Value
            Range("AT" & k).Interior.Color = Coul
            k = k + 1
        End If
        If Range("AU" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AU3").Value
            Range("A" & k & ":AU" & k).Value = Range("A" & i & ":AU" & i).Value
            Range("AU" & k).Interior.Color = Coul
            k = k + 1
        End If
        If Range("AV" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AV3").Value
            Range("A" & k & ":AV" & k).Value = Range("A" & i & ":AV" & i).Value
            Range("AV" & k).Interior.Color = Coul
            k = k + 1
        End If
        If Range("AW" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AW3").Value
            Range("A" & k & ":AW" & k).Value = Range("A" & i & ":AW" & i).Value
            Range("AW" & k).Interior.Color = Coul
            k = k + 1
        End If
        If Range("AX" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AX3").Value
            Range("A" & k & ":AX" & k).Value = Range("A" & i & ":AX" & i).Value
            Range("AX" & k).Interior.Color = Coul
            k = k + 1
        End If
        If Range("AY" & i).Interior.Color = Coul Then
            Range("J" & k).Value = Range("AY3").Value
            Range("A" & k & ":AY" & k).Value = Range("A" & i & ":AY" & i).Value
            Range("AY" & k).Interior.Color = Coul
            k = k + 1
        End If
    Next
End Sub

Cdlt
Cliquez pour agrandir...
Re bonjour Rouge,
En appliquant celle-ci je me rend compte que tu ne viens pas écrire le contenu des colonnes en AU3, AV3, ... dans les lignes J correspondantes.
As-tu un moyen d'ajouter cela ?

Bien à toi
Guil
 
Vote positif 0 Vote négatif
R

Rouge

XLDnaute Impliqué
Bonjour,

Je ne comprends pas, d'une part soan, que je salue, vous a fait une proposition qui vous convenait, alors pourquoi revenir sur ma proposition qui n'était que la reprise de votre macro légèrement corrigée.

D'autre part je ne retrouve plus votre macro d'origine.

Cdlt
 
Vote positif 0 Vote négatif
G

Guileo

XLDnaute Nouveau
Rouge à dit:
Bonjour,

Je ne comprends pas, d'une part soan, que je salue, vous a fait une proposition qui vous convenait, alors pourquoi revenir sur ma proposition qui n'était que la reprise de votre macro légèrement corrigée.

D'autre part je ne retrouve plus votre macro d'origine.

Cdlt
Cliquez pour agrandir...
Bonjour,
Merci de votre retour. C'est pour avoir les 2 options et pouvoirs proposer.
La macro initiale est ci-joint.
Il n'y a qu'une légère modification à apporter de celle que vous m'avez amélioré :)

Bien à vous,
Guil
 

Pièces jointes

  • MacroTest.xlsm
    296.9 KB · Affichages: 3
Vote positif 0 Vote négatif
R

Rouge

XLDnaute Impliqué
"Merci de votre retour. C'est pour avoir les 2 options et pouvoirs proposer."

Là, votre raisonnement n'est pas bon, Soan vous à proposer un code simple et efficace alors que moi je n'ai que corriger votre code initial, entre les 2 il n'y a pas photo, d'autant plus que le nouveau fichier comporte des colonnes supplémentaires et on ne sait pas où cela va s'arrêter, donc inutile de continuer à vouloir appliquer le correctif de votre code car il n'est pas évolutif.
Si, sur le code de Soan, il y a quelques adaptation à faire, il s'est gentiment proposé de vous les faire.
Quant à ma proposition initiale, laissez tombé, ça n'a pas de sens logique.

Cdlt
 
Vote positif 0 Vote négatif

Discussions similaires

N
  • Question
Microsoft 365 afficher/masquer des lignes en fonction de la valeur d'une cellule qui aura été renseignée par une autre feuille (via un copier/collé automatique)
Réponses
5
Affichages
451
Nel'
N
S
  • Résolu(e)
Microsoft 365 vba, récupérer le résultat d'un INDEX(EQUIV en fonction du résultat
Réponses
6
Affichages
427
SOP
S
G
  • Question
Microsoft 365 MACRO pour détecter une cellule de couleur et créer une colonne
Réponses
1
Affichages
794
soan
S
C
  • Résolu(e)
Microsoft 365 Mise en forme d'une ligne d'après listes déroulantes + clic sur un bouton
Réponses
2
Affichages
548
casualexcel
C
N
  • Question
Microsoft 365 VBA Supprimer lignes en fonction des valeurs d'une cellule
Réponses
11
Affichages
2 K
Phil69970
Phil69970
A
  • Résolu(e)
XL 2010 VBA Reporter et sommer des valeurs en fonction d'une référence et d'un n° de semaine
2
Réponses
20
Affichages
1 K
arno1234
A
O
  • Question
XL 2016 Problématique écritures comptables - formule Excel et Macro VBA simple
Réponses
9
Affichages
1 K
fanfan38
fanfan38
S
  • Question
Microsoft 365 Afficher dans un tableau les noms des feuilles d'un fichier excel ainsi que le nombre de lignes renseignées pour chacune d'elle.
Réponses
2
Affichages
559
chris
chris
suzannegobeil
  • Résolu(e)
XL 2016 Créer Macro pour imprimer un nombre d'étiquettes en fonction d'une colonne Excel "Quantité"
Réponses
4
Affichages
997
suzannegobeil
suzannegobeil
S
  • Résolu(e)
XL 2016 VBA effacer contenu colonne en fonction des infos d'une autre
Réponses
8
Affichages
715
sandfer
S

Membres actuellement en ligne

2 membres et 58 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
315 134
Messages
2 116 614
Membres
112 811
dernier inscrit
shade1452