XL 2016 Insertion d'une ligne si conditions respectées

[Lddr]

Bonjour à toutes et à tous,

Je suis débutant en Vba et je n'arrive pas à faire une macro qui permet d'ajouter une ligne sous deux conditions.

Pour expliquer simplement :
La feuille "critere" est le point de départ. On y trouve un tableau avec en ordonnée des noms de régions (Bretagne, Ile de France, Nouvelle Aquitaine) et en abscisse des critères lambdas (C1, C2, C3).
Un point important est le fait que le nombre de régions peut évoluer tandis que les critères seront toujours C1, C2 et C3.

Pour exprimer mon besoin, voici un exemple :
Imaginons que six cases comprennent un X (Bretagne/C1, Bretagne/C2, Ile de France/C1, Ile de France/C2, Nouvelle Aquitaine/C1 et Nouvelle Aquitaine/C2.
S'il y a un X, le programme doit ajouter une ligne dans la feuille nommée "Data" au niveau de Bretagne , Ile de France et Nouvelle Aquitaine "sous" les critères C1 et C2.
Le programme doit de plus écrire dans les six lignes ajoutées le mot compris dans la case "A1" sur la feuille "critere".
Ce mot doit être surligné en vert.

S'il n'y a pas de "X" mais un "-", alors le programme ne doit pas ajouter de ligne.

Afin d'illustrer cette explication, j'ai ajouté dans le fichier Excel la feuille "Résultat voulu" qui illustre ce que le programme doit me permettre d'obtenir comme résultat.

Vous trouverez dans mon post le fichier Excel.
J'ai essayé d'écrire une macro mais sans succès...

Sub Insereligne() 'Insertion d'une ligne s'il y a un X dans la case, sinon ne pas ajouter de ligne

Dim VRegion As Range, Vcritere As Range, Plage As Range, Plage1 As Range Dim wsE As Worksheet Dim wsB As Worksheet Dim i As Integer, j As Integer

Set wsE = ThisWorkbook.Worksheets("critere")
Set wsB = ThisWorkbook.Worksheets("Data")

wsE.Activate
Set Plage = Range(Cells(3, 2), Cells(65000, 2)) Set Plage1 = Range(Cells(3, 3), Cells(65000, 5))

For Each VRegion In Plage
For Each Vcritere In Plage1
For i = 1 To wsB.Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To wsB.Cells(3, Columns.Count).End(xltolft).Column - 1
If Cells(i, 1) = Vregion And Cells(i, j) = "X" Then
wsB.Cells(i, 1).EntireRow.Insert Shift:=xlDown
Exit For
End If
Next

End Sub

Un grand merci à ceux qui prendront le temps de répondre à ce post.

Très bonne journée à vous !

LDDR

 

[sylvanu]

Bonjour Lddr, et bienvenu sur XLD.
Bien que vu par beaucoup, votre post reste sans réponse.
Le problème pour vous apporter une réponse vient du fait qu'il y a de nombreuses cellules fusionnées.
Et insérer des lignes alors que les deux colonnes de gauche ont des cellules fusionnées, qui plus est pas de même taille, relève pour beaucoup d'entre nous de la gageure.
Ne pouvez vous pas trouver une présentation de Data sans ces cellules fusionnées ?

 

[Lddr]

Bonjour Lddr, et bienvenu sur XLD.
Bien que vu par beaucoup, votre post reste sans réponse.
Le problème pour vous apporter une réponse vient du fait qu'il y a de nombreuses cellules fusionnées.
Et insérer des lignes alors que les deux colonnes de gauche ont des cellules fusionnées, qui plus est pas de même taille, relève pour beaucoup d'entre nous de la gageure.
Ne pouvez vous pas trouver une présentation de Data sans ces cellules fusionnées ?

Bonjour Sylvanu,

Premièrement merci pour votre acceuil.

Merci beaucoup pour votre retour sur mon post, qui en effet ne suscite pas beaucoup de réactions !
En effet c'est la difficulté... et je ne peux malheureusement m'en défaire puisque le fichier de base est construit de cette manière et je ne peux le modifier...

LDDR

 

[sylvanu]

La difficulté est que les cellules fusionnées ont une valeur nulle, sauf la première qui a la bonne valeur.
La seconde difficulté est qu'il est difficile de trouver la zone de travail. Dans votre fichier, B32=C32=0 et B33=C33=0. Comment savoir que le tableau se termine en ligne 32 et non en ligne 33?

 

[Lddr]

La difficulté est que les cellules fusionnées ont une valeur nulle, sauf la première qui a la bonne valeur.
La seconde difficulté est qu'il est difficile de trouver la zone de travail. Dans votre fichier, B32=C32=0 et B33=C33=0. Comment savoir que le tableau se termine en ligne 32 et non en ligne 33?

Voici une solution que je viens de trouver et semble marcher.

Sub insertion()

Dim Vregion As Range, Vcritere As Range, Plage As Range, Plage1 As Range
Dim wsE As Worksheet
Dim wsB As Worksheet
Dim i As Integer, j As Integer

Set wsE = ThisWorkbook.Worksheets("critere")
Set wsD = ThisWorkbook.Worksheets("Data")

Set rg_condition = wsE.Cells(2, 2).Resize(wsE.Cells(3, 3).End(xlDown).Row - 1, wsE.Cells(3, 3).End(xlToRight).Column - 1)

'ici n=5 car
'wsD.Cells(Rows.Count, 2).End(xlUp).Row=27

n = wsD.Cells(Rows.Count, 2).End(xlUp).Row + 5
Set rg_region = wsD.Range("B3:B" & n)

For i = 3 To n
valeur = Empty
If IsEmpty(wsD.Cells(i, 2)) Then
region_1 = region
region = region
Else
region_1 = region
region = wsD.Cells(i, 2).Value
End If

If IsEmpty(wsD.Cells(i, 3)) Then

critere_1 = wsD.Cells(i - 1, 3).Value
critere = critere
Else

critere_1 = critere
critere = wsD.Cells(i, 3).Value
End If

If critere <> critere_1 And i <> 3 Then

'condition si X
On Error Resume Next
valeur = wsE.Cells(rg_condition.Find(region_1).Row, rg_condition.Find(critere_1).Column).Value
If valeur = "X" Then
wsD.Cells(i - 1, 1).EntireRow.Insert Shift:=xlDown
wsD.Cells(i, 4).Value = "OUI"
wsD.Cells(i, 4).Interior.Color = vbGreen
'comme on ajoute une ligne
i = i + 1

'condition si critère=1 ligne alors merge avec cellule au dessus
If wsD.Cells(i - 1, 3).Value <> wsD.Cells(i, 3).Value And Not IsEmpty(wsD.Cells(i - 1, 3)) Then
wsD.Cells(i - 2, 3).Resize(2, 1).Merge
End If

End If
End If

Next
End Sub