Sélectionner le rectangle qui a le plus nombre de cellules
Bonjour le Forum,
J'ai une question comment on peut définir le plage de rectangle qui sera établi par les cellules non vides. Ce rectangle devra avoir le plus nombre de cellules par rapport aux autres rectangles eventuels.
j'ai essayé de faire l'Explication détaillée dans le fichier en joint.
Merci de votre contribution à resoudre de cette question.
cordialement
Bonjour Sakman, bonjour le forum,
Regarde le code ci-dessous. Je n'obtiens pas le même résultat que toi mais je considère que ce que j'obtiens est aussi vrai... C'est un peu long a traiter mais la tâche n'est pas simple. J'imagine qu'il y a bien plus rapide et moins "tiré par les cheveux" mais j'ai pas mieux... Je n'ai testé qu'avec ton tableau...
Le code :
Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CNV As Range 'déclare la variable CNV (plage des Celules Non Vides)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim X As Integer 'déclare la variable X (incrément)
Dim PR As Range 'déclare la variable PR (PLage des Rectangles)
Dim NC As Integer 'déclare la variable NC (Nombre de Cellules)
Dim TR() As Variant 'déclare la variable TR (Tableau des Rectangles)
Dim I As Integer 'déclare la variable I (Incrément)
Dim T0 As String 'déclare la variable T0 (Temporaire 0)
Dim T1 As Integer 'déclare la variable T1 (Temporaire 1)
Set O = Worksheets("question") 'définit l'onglet O
Set PL = O.Cells.SpecialCells(xlCellTypeConstants) 'définit la plage PL
Set CNV = O.Range("A1") 'initialise la plage CNV
For Each CEL In PL 'boucle sur toutes les cellules CEL dans la plage PL
'si la cellule CEL contient "x", définit la palge CNV
If CEL.Value = "x" Then Set CNV = IIf(CNV.Address = "$A$1", CEL, Application.Union(CNV, CEL))
Next CEL 'prochaine cellule CEL de la boucle
CNV.Select
For Each CEL In CNV 'boucle sur toutes les cellules CEL de la palge CNV
X = 0 'initialise la variable X
Set PR = Range(CEL, CEL.End(xlToRight)) 'définit la plage PR
Set PR = Range(PR, CEL.End(xlDown)) 'redéfinit la plage PR
If Application.WorksheetFunction.CountBlank(PR) <> 0 Then 'condition 1 : si la plage PR contient des cellules vides
Do Until Application.WorksheetFunction.CountBlank(PR) = 0 'boucle jusqu'à ce que la plage PR ne contienne aucune cellule vide
X = X + 1 'incrémente X
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set PR = PR.Resize(PR.Rows.Count, PR.Columns.Count - 1) 'redéfinit PR sans la dernière colonne (génère une erreur quand X est supérieure ou égale au nombre de colonnes de PR)
If Err <> 0 Then 'condition 2 : si une erreur a été générée
Err.Clear 'supprime l'erreur
GoTo suite 'va à l'étiquette "suite"
End If 'fin de la condition 2
On Error GoTo 0 'annule la gestion des erreurs
Loop 'boucle
End If 'fin de la condition 1
NC = Application.WorksheetFunction.CountA(PR) 'définit le nombre de cellules NC de la plage PR
ReDim Preserve TR(1, I) 'redimensionne le tableau TR
TR(0, I) = PR.Address(0, 0) 'récupère l'adresse de la plage PR dans la ligne 0 de TR
TR(1, I) = NC 'récupère le nombre de cellules de la plage PR
I = I + 1 'incrémente I
suite: 'étiquette
Next CEL 'prochaine cellule de la plage
'tri du tableau TR
For I = 0 To UBound(TR, 2) 'boucle 1 : sur tous les nombre de cellules du tableau TR
For J = 0 To UBound(TR, 2) 'boucle 1 : sur tous les nombre de cellules du tableau TR
If TR(1, J) < TR(1, I) Then 'condition : si la valeur de la boucle 2 est inférieure à la valeur de la boucle 1
T0 = TR(0, J): T1 = TR(1, J) 'récupère les valeur de la boucle 2 dans les variable T0 et T1
TR(0, J) = TR(0, I): TR(1, J) = TR(1, I) 'remplace les valeurs de la boucle 2 par celles de la boucle 1
TR(0, I) = T0: TR(1, I) = T1 'remplace les valeur de la boucle 1 par celles des variables T0 et T1
End If 'fin de la condition
Next J 'prochain nombre de cellules de la boucle 2
Next I 'prochain nombre de cellules de la boucle 1
'revoi du top 10 à partir de la cellule T35
For I = 1 To 10 'boucle de 1 à 10
O.Cells(34 + I, 20) = "Rang " & I 'renvoie le rang en colonne T
O.Cells(34 + I, 21) = TR(0, I - 1) 'renvoie l'adresse du rectangle en colonne U
O.Cells(34 + I, 22) = TR(1, I - 1) 'ernvoie le nombre de cellules en colonne T
Next I 'prochaine valeur de la boucle
End SubBonjour Thau Thème et le Forum
Tout d'abord, je te remercie mille fois pour ton interet et pour le grande support afin de resoudre mon problème.
j'ai essayé ton code tres intelligent pour cette tellement difficile tache.
Comme tu l'as dit que les resultats obtenus par ton macro sont un peu different que les miens ecrits manuelement.
J'ai ajouté le fichier contenant les resultats obtenus. Et j'ai essayé d'ecrire mes remarques avec mon français. Si tu le regardes et si tu prends en compte mes remarques pour la resolution de ce probleme je serai vraiment tres heureux...
Grace à toi je pourrai garder les cheveux.....
Encore une fois Tres Grande MERCI à toi..
A +
Bonjour Thau Thème et le Forum
Tout d'abord, je te remercie mille fois pour ton interet et pour le grande support afin de resoudre mon problème.
j'ai essayé ton code tres intelligent pour cette tellement difficile tache.
Comme tu l'as dit que les resultats obtenus par ton macro sont un peu different que les miens ecrits manuelement.
J'ai ajouté le fichier contenant les resultats obtenus. Et j'ai essayé d'ecrire mes remarques avec mon français. Si tu le regardes et si tu prends en compte mes remarques pour la resolution de ce probleme je serai vraiment tres heureux...
Grace à toi je pourrai garder les cheveux.....
Encore une fois Tres Grande MERCI à toi..
A +
Re,
Bon, je crois qu'on y est ! Ça ma l'air même un peu plus rapide mais toujours aussi "tiré par les cheveux"...
Le code :
Sub Macro1()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CNV As Range 'déclare la variable CNV (plage des Celules Non Vides)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim X As Integer 'déclare la variable X (incrément)
Dim PR As Range 'déclare la variable PR (PLage des Rectangles)
Dim I As Integer 'déclare la variable I (Incrément)
Dim NP As Integer 'déclare la variable NP (Nombre de Plages)
Dim NC As Integer 'déclare la variable NC (Nombre de Cellules)
Dim TR() As Variant 'déclare la variable TR (Tableau des Rectangles)
Dim J As Integer 'déclare la variable J (incrément)
Dim T0 As String 'déclare la variable T0 (Temporaire 0)
Dim T1 As Integer 'déclare la variable T1 (Temporaire 1)
'définition la plage des cellules contenant "x"
Set O = Worksheets("question") 'définit l'onglet O
Set PL = O.Cells.SpecialCells(xlCellTypeConstants) 'définit la plage PL
Set CNV = O.Range("A1") 'initialise la plage CNV
For Each CEL In PL 'boucle sur toutes les cellules CEL dans la plage PL
'si la cellule CEL contient "x", définit la plage CNV
If CEL.Value = "x" Then Set CNV = IIf(CNV.Address = "$A$1", CEL, Application.Union(CNV, CEL))
Next CEL 'prochaine cellule CEL de la boucle
For Each CEL In CNV 'boucle sur toutes les cellules CEL de la plage CNV
'définition d'un rectangle sans cellule vide au milieu
X = 0 'initialise la variable X
Set PR = Range(CEL, CEL.End(xlToRight)) 'définit la plage PR
Set PR = Range(PR, CEL.End(xlDown)) 'redéfinit la plage PR
If Application.WorksheetFunction.CountBlank(PR) <> 0 Then 'condition 1 : si la plage PR contient des cellules vides
Do Until Application.WorksheetFunction.CountBlank(PR) = 0 'boucle jusqu'à ce que la plage PR ne contienne aucune cellule vide
X = X + 1 'incrémente X
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set PR = PR.Resize(PR.Rows.Count, PR.Columns.Count - 1) 'redéfinit PR sans la dernière colonne (génère une erreur quand X est supérieure ou égale au nombre de colonnes de PR)
If Err <> 0 Then 'condition 2 : si une erreur a été générée
Err.Clear 'supprime l'erreur
GoTo suite 'va à l'étiquette "suite"
End If 'fin de la condition 2
On Error GoTo 0 'annule la gestion des erreurs
Loop 'boucle
End If 'fin de la condition 1
'Vérification si la nouvelle plage n'est pas déjà incluse dans une ancienne
If I > 0 Then 'condition 1 : si I est supérieure à 0 (=> le tableau TR contient au moins une plage)
For NP = 0 To UBound(TR, 2) 'boucle sur toutes les plages du tableau TR
'condition 2 : si la plage de la boucle contient plus de cellules que PR
If O.Range(TR(0, NP)).Cells.Count > PR.Cells.Count Then
'condition 3 : si l'intersection entre PR et la plage de la boucle n'est pas vide
If Not Application.Intersect(PR, O.Range(TR(0, NP))) Is Nothing Then
'si l'adresse de l'intersection est la même que celle de PR, PR est incluse dans la plage
'de la boucle, inutile alors de rajouter PR au tableau des plages TR, va à l'étiquette "suite"
If Application.Intersect(PR, O.Range(TR(0, NP))).Address = PR.Address Then GoTo suite
End If 'fin de la condition 3
End If 'fin de la condition 2
Next NP 'prochaine plage de la boucle
End If 'fin de la condition 1
'rajout de la plage au tableau des rectangles
NC = Application.WorksheetFunction.CountA(PR) 'définit le nombre de cellules NC de la plage PR
ReDim Preserve TR(1, I) 'redimensionne le tableau TR
TR(0, I) = PR.Address(0, 0) 'récupère l'adresse de la plage PR dans la ligne 0 de TR
TR(1, I) = NC 'récupère le nombre de cellules de la plage PR
I = I + 1 'incrémente I
suite: 'étiquette
Next CEL 'prochaine cellule de la plage
'tri du tableau TR
For I = 0 To UBound(TR, 2) 'boucle 1 : sur tous les nombre de cellules du tableau TR
For J = 0 To UBound(TR, 2) 'boucle 1 : sur tous les nombre de cellules du tableau TR
If TR(1, J) < TR(1, I) Then 'condition : si la valeur de la boucle 2 est inférieure à la valeur de la boucle 1
T0 = TR(0, J): T1 = TR(1, J) 'récupère les valeur de la boucle 2 dans les variable T0 et T1
TR(0, J) = TR(0, I): TR(1, J) = TR(1, I) 'remplace les valeurs de la boucle 2 par celles de la boucle 1
TR(0, I) = T0: TR(1, I) = T1 'remplace les valeur de la boucle 1 par celles des variables T0 et T1
End If 'fin de la condition
Next J 'prochain nombre de cellules de la boucle 2
Next I 'prochain nombre de cellules de la boucle 1
'revoi du top 10 à partir de la cellule T35
For I = 1 To 10 'boucle de 1 à 10
O.Cells(34 + I, 20) = "Rang " & I 'renvoie le rang en colonne T
O.Cells(34 + I, 21) = TR(0, I - 1) 'renvoie l'adresse du rectangle en colonne U
O.Cells(34 + I, 22) = TR(1, I - 1) 'ernvoie le nombre de cellules en colonne v
Next I 'prochaine valeur de la boucle
End SubBonsoir Thau Thème,
Tu as professionnellement réalisé une touche tres précis sur les intersections des rectangles. Tu as corrigé toutes les intersections vers le haut (verticallement) et donc tu as trouvé le resultat que J'ai manuellement ecris dans le premier post.(sauf un rectangle)
Comme j'avais ecrit dans le post #1,
"(J'ai vu que , Rect.No3 est faux. car Rect.No.7 comporte le Rect.No3......."
le resultat rang No.8 H7:I15 est une partie de No.5 (C7:I15) et Dautre part No.10 ton code a trouvé P3:Q8. Ça doit etre normalement J3:Q8
Donc on parle de l'intersection en horizontale maintenant...(vers le gauche)....
Ton travail c'est super moi....C'est déja tres tres suffisant pour moi. Je crois que je pourrai realiser les revisions nécessaire d'apres tes codes. Tu as déja depensé beaucoup d'effort et beaucoup de temps pour moi.
Merci mille fois pour tous... (Travail Professionnel , Patient , Effort etc....)
Bon courage...
Bonsoir Sakman, bonsoir le forum,
En effet, le code a encore des défauts !... Mais maintenant, c'est surtout à toi qu'il faut souhaiter bon courage... Merci pour ton avis bienveillant.
Salut !
Juste un message pour m'"accrocher" et être informé de la suite de la discussion...
Je me suis laissé aussi tenté par cette question... J'ai certainement codé un peu vite
Je reviens si j'arrive à un résultat !
Cordialement.
Bonjour ThauThème
Malgré tous , je te remercie pour tous.
C'est toi qui m'as donné une lumiére pour pouvoir passer le tunnel sombré.
un Grande Merci à toi
Bye..
Salut Ferrand,
avant d'attaquer à mon projet de travail, j'attendrai ta reponse pour pouvoir appliquer cette solution sur mon projet.
En attendant , je serai occupé avec l'adaptation , la revision et la réecriture d'un macro d'apres les codes de Mr. ThauThème.
Bon courrage...
Bonjour le Fil, bonjour le forum,
Une nouvelle proposition :
Sub Macro1()
Dim DL As Long 'déclare la variable DL (Dernière Ligne)
Dim DC As Integer 'déclare la variable DC (Dernière Colonne)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CNV As Range 'déclare la variable CNV (plage des Celules Non Vides)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim X As Integer 'déclare la variable X (incrément)
Dim PR1 As Range 'déclare la variable PR1 (PLage des Rectangles 1)
Dim PR2 As Range 'déclare la variable PR2 (PLage des Rectangles 2)
Dim I As Integer 'déclare la variable I (Incrément)
Dim NP As Integer 'déclare la variable NP (Nombre de Plages)
Dim NC As Integer 'déclare la variable NC (Nombre de Cellules)
Dim TR() As Variant 'déclare la variable TR (Tableau des Rectangles)
Dim J As Integer 'déclare la variable J (incrément)
Dim T0 As String 'déclare la variable T0 (Temporaire 0)
Dim T1 As Integer 'déclare la variable T1 (Temporaire 1)
Dim TEST As Boolean 'déclare la variable TEST
DL = 1 'initialise la variable DL
DC = 1 'initialise la variable DC
'définition la plage des cellules contenant "x"
Set O = Worksheets("question") 'définit l'onglet O
Set PL = O.Cells.SpecialCells(xlCellTypeConstants) 'définit la plage PL
Set CNV = O.Range("A1") 'initialise la plage CNV
For Each CEL In PL 'boucle sur toutes les cellules CEL dans la plage PL
If CEL.Value = "x" Then 'condition : si la cellule CEL contient "x"
If CEL.Row > DL Then DL = CEL.Row 'définit la dernière ligne DL
If CEL.Column > DC Then DC = CEL.Column 'définit la dernière colonne DL
End If 'fin de la condition
Set CNV = IIf(CNV.Address = "$A$1", CEL, Application.Union(CNV, CEL)) 'définit la plage CNV
Next CEL 'prochaine cellule CEL de la boucle
For Each CEL In CNV 'boucle sur toutes les cellules CEL de la plage CNV
X = 0 'initialise la variable X
'définition d'un rectangle sans cellule vide au milieu (vertical)
Set PR1 = IIf(CEL.End(xlToRight).Column > DC, Range(CEL, Cells(CEL.Row, DC)), Range(CEL, CEL.End(xlToRight))) 'définit la plage PR1
Set PR1 = IIf(PR1.End(xlDown).Row > DL, Range(PR1, Cells(CEL.Row, DL)), Range(PR1, CEL.End(xlDown))) 'redéfinit la plage PR1
If Application.WorksheetFunction.CountBlank(PR1) <> 0 Then 'condition 1 : si la plage PR1 contient des cellules vides
Do Until Application.WorksheetFunction.CountBlank(PR1) = 0 'boucle jusqu'à ce que la plage PR1 ne contienne aucune cellule vide
X = X + 1 'incrémente X
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set PR1 = PR1.Resize(PR1.Rows.Count, PR1.Columns.Count - 1) 'redéfinit PR1 sans la dernière colonne (génère une erreur quand X est supérieure ou égale au nombre de colonnes de PR1)
If Err <> 0 Then 'condition 2 : si une erreur a été générée
Err.Clear 'supprime l'erreur
GoTo suite1 'va à l'étiquette "suite1"
End If 'fin de la condition 2
On Error GoTo 0 'annule la gestion des erreurs
Loop 'boucle
End If 'fin de la condition 1
'Vérification si la nouvelle plage n'est pas déjà incluse dans une ancienne
If I > 0 Then 'condition 1 : si I est supérieure à 0 (=> le tableau TR contient au moins une plage)
For NP = 0 To UBound(TR, 2) 'boucle sur toutes les plages du tableau TR
'condition 2 : si la plage de la boucle contient plus de cellules que PR1
If O.Range(TR(0, NP)).Cells.Count > PR1.Cells.Count Then
'condition 3 : si l'intersection entre PR1 et la plage de la boucle n'est pas vide
If Not Application.Intersect(PR1, O.Range(TR(0, NP))) Is Nothing Then
'si l'adresse de l'intersection est la même que celle de PR1, PR1 est incluse dans la plage
'de la boucle, inutile alors de rajouter PR1 au tableau des plages TR, va à l'étiquette "suite1"
If Application.Intersect(PR1, O.Range(TR(0, NP))).Address = PR1.Address Then GoTo suite1
End If 'fin de la condition 3
End If 'fin de la condition 2
Next NP 'prochaine plage de la boucle
End If 'fin de la condition 1
'rajout de la plage au tableau des rectangles
NC = Application.WorksheetFunction.CountA(PR1) 'définit le nombre de cellules NC de la plage PR1
ReDim Preserve TR(1, I) 'redimensionne le tableau TR
TR(0, I) = PR1.Address(0, 0) 'récupère l'adresse de la plage PR1 dans la ligne 0 de TR
TR(1, I) = NC 'récupère le nombre de cellules de la plage PR1
I = I + 1 'incrémente I
suite1: 'étiquette
X = 0 'initialise la variable X
'définition d'un rectangle sans cellule vide au milieu (horizontal)
Set PR2 = IIf(CEL.End(xlDown).Row > DL, Range(CEL, Cells(CEL.Row, DL)), Range(CEL, CEL.End(xlDown))) 'définit la plage PR2
Set PR2 = IIf(PR2.End(xlToRight).Column > DC, Range(PR2, Cells(CEL.Row, DC)), Range(PR2, CEL.End(xlToRight))) 'redéfinit la plage PR2
If Application.WorksheetFunction.CountBlank(PR2) <> 0 Then 'condition 1 : si la plage PR2 contient des cellules vides
Do Until Application.WorksheetFunction.CountBlank(PR2) = 0 'boucle jusqu'à ce que la plage PR2 ne contienne aucune cellule vide
X = X + 1 'incrémente X
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set PR2 = PR2.Resize(PR2.Rows.Count - 1, PR2.Columns.Count) 'redéfinit PR2 sans la dernière colonne (génère une erreur quand X est supérieure ou égale au nombre de colonnes de PR2)
If Err <> 0 Then 'condition 2 : si une erreur a été générée
Err.Clear 'supprime l'erreur
GoTo suite2 'va à l'étiquette "suite2"
End If 'fin de la condition 2
On Error GoTo 0 'annule la gestion des erreurs
Loop 'boucle
End If 'fin de la condition 1
If PR1.Address = PR2.Address Then GoTo suite2 'si les plages sont identiques, va a l'étiquette "suite2"
'Vérification si la nouvelle plage n'est pas déjà incluse dans une ancienne
If I > 0 Then 'condition 1 : si I est supérieure à 0 (=> le tableau TR contient au moins une plage)
For NP = 0 To UBound(TR, 2) 'boucle sur toutes les plages du tableau TR
'condition 2 : si la plage de la boucle contient plus de cellules que PR2
If O.Range(TR(0, NP)).Cells.Count > PR2.Cells.Count Then
'condition 3 : si l'intersection entre PR2 et la plage de la boucle n'est pas vide
If Not Application.Intersect(PR2, O.Range(TR(0, NP))) Is Nothing Then
'si l'adresse de l'intersection est la même que celle de PR2, PR2 est incluse dans la plage
'de la boucle, inutile alors de rajouter PR2 au tableau des plages TR, va à l'étiquette "suite2"
If Application.Intersect(PR2, O.Range(TR(0, NP))).Address = PR2.Address Then GoTo suite2
End If 'fin de la condition 3
End If 'fin de la condition 2
Next NP 'prochaine plage de la boucle
End If 'fin de la condition 1
'rajout de la plage au tableau des rectangles
NC = Application.WorksheetFunction.CountA(PR2) 'définit le nombre de cellules NC de la plage PR1
ReDim Preserve TR(1, I) 'redimensionne le tableau TR
TR(0, I) = PR2.Address(0, 0) 'récupère l'adresse de la plage PR2 dans la ligne 0 de TR
TR(1, I) = NC 'récupère le nombre de cellules de la plage PR
I = I + 1 'incrémente I
suite2: 'étiquette
Next CEL 'prochaine cellule de la plage
'modifie les plage de TR incluses dans d'autres pour les renvoyer en bas de tableau après le tri
For I = 0 To UBound(TR, 2) 'boucle 1 : sur toutes les plage de rectangle du tableau TR
For J = 0 To UBound(TR, 2) 'boucle 2 : sur toutes les plage de rectangle du tableau TR
If J <> I Then 'condition 1 : si la variable j est différente de I
If Not Application.Intersect(O.Range(TR(0, I)), O.Range(TR(0, J))) Is Nothing Then 'condition 2 : si les deux plages ont des cellules en commun
'condition 3 : si la plage de boucle 2 est incluse dans la plage de la boucle 1
If Application.Union(O.Range(TR(0, I)), O.Range(TR(0, J))).Address = O.Range(TR(0, I)).Address Then
TR(0, J) = "A1:A2": TR(1, J) = 0 'redéfinit la plage de la boucle 2 (n'importe laqelle hors de CNV), redéfinit le nombre de cellules de la plage
End If 'fin de la condition 3
If TR(0, I) <> TR(0, J) Then 'condition 4 : si les plages sont différentes (je ne sais plus pourqoi j'ai mis cette condition...)
'condition 5 : si la plage de boucle 1 est incluse dans la plage de la boucle 2
If Application.Union(O.Range(TR(0, I)), O.Range(TR(0, J))).Address = O.Range(TR(0, J)).Address Then
TEST = True 'définit la varaiable TEST
End If 'fin de la condition 5
End If 'fin de la condition 4
End If 'fin de la condition 2
End If 'fin de la condition 1
Next J 'prochaine plage de la boucle 2
'si TEST est [VRAI],redéfinit la plage de la boucle 1 (n'importe laqelle hors de CNV), redéfinit le nombre de cellules de la plage, redéfinit TEST
If TEST = True Then TR(0, I) = "A1:A2": TR(1, I) = 0: TEST = False
Next I 'prochaine plage de la boucle 1
'tri du tableau TR
For I = 0 To UBound(TR, 2) 'boucle 1 : sur tous les nombre de cellules du tableau TR
For J = 0 To UBound(TR, 2) 'boucle 1 : sur tous les nombre de cellules du tableau TR
If TR(1, J) < TR(1, I) Then 'condition : si la valeur de la boucle 2 est inférieure à la valeur de la boucle 1
T0 = TR(0, J): T1 = TR(1, J) 'récupère les valeur de la boucle 2 dans les variable T0 et T1
TR(0, J) = TR(0, I): TR(1, J) = TR(1, I) 'remplace les valeurs de la boucle 2 par celles de la boucle 1
TR(0, I) = T0: TR(1, I) = T1 'remplace les valeur de la boucle 1 par celles des variables T0 et T1
End If 'fin de la condition
Next J 'prochain nombre de cellules de la boucle 2
Next I 'prochain nombre de cellules de la boucle 1
'revoi du top 10 à partir de la cellule T35
For I = 1 To 10 'boucle de 1 à 10
O.Cells(34 + I, 20) = "Rang " & I 'renvoie le rang en colonne T
O.Cells(34 + I, 21) = TR(0, I - 1) 'renvoie l'adresse du rectangle en colonne U
O.Cells(34 + I, 22) = TR(1, I - 1) 'ernvoie le nombre de cellules en colonne v
Next I 'prochaine valeur de la boucle
End SubÇa me semble correct mais chaque fois que je dit ça je me plante. D'ailleurs je ne le dis plus. Me*** trop tard !...
Re,
Puisque les plages sont vérifiés à la fin, nouveau code simplifié :
Sub Macro1()
Dim DL As Long 'déclare la variable DL (Dernière Ligne)
Dim DC As Integer 'déclare la variable DC (Dernière Colonne)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CNV As Range 'déclare la variable CNV (plage des Celules Non Vides)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim PR1 As Range 'déclare la variable PR1 (PLage des Rectangles 1)
Dim PR2 As Range 'déclare la variable PR2 (PLage des Rectangles 2)
Dim I As Integer 'déclare la variable I (Incrément)
Dim NC As Integer 'déclare la variable NC (Nombre de Cellules)
Dim TR() As Variant 'déclare la variable TR (Tableau des Rectangles)
Dim J As Integer 'déclare la variable J (incrément)
Dim T0 As String 'déclare la variable T0 (Temporaire 0)
Dim T1 As Integer 'déclare la variable T1 (Temporaire 1)
Dim TEST As Boolean 'déclare la variable TEST
DL = 1 'initialise la variable DL
DC = 1 'initialise la variable DC
'définition la plage des cellules contenant "x"
Set O = Worksheets("question") 'définit l'onglet O
Set PL = O.Cells.SpecialCells(xlCellTypeConstants) 'définit la plage PL
Set CNV = O.Range("A1") 'initialise la plage CNV
For Each CEL In PL 'boucle sur toutes les cellules CEL dans la plage PL
If CEL.Value = "x" Then 'condition : si la cellule CEL contient "x"
If CEL.Row > DL Then DL = CEL.Row 'définit la dernière ligne DL
If CEL.Column > DC Then DC = CEL.Column 'définit la dernière colonne DC
End If 'fin de la condition
Set CNV = IIf(CNV.Address = "$A$1", CEL, Application.Union(CNV, CEL)) 'définit la plage CNV
Next CEL 'prochaine cellule CEL de la boucle
For Each CEL In CNV 'boucle sur toutes les cellules CEL de la plage CNV
'définition d'un rectangle sans cellule vide au milieu (vertical)
Set PR1 = IIf(CEL.End(xlToRight).Column > DC, Range(CEL, Cells(CEL.Row, DC)), Range(CEL, CEL.End(xlToRight))) 'définit la plage PR1
Set PR1 = IIf(PR1.End(xlDown).Row > DL, Range(PR1, Cells(CEL.Row, DL)), Range(PR1, CEL.End(xlDown))) 'redéfinit la plage PR1
If Application.WorksheetFunction.CountBlank(PR1) <> 0 Then 'condition 1 : si la plage PR1 contient des cellules vides
Do Until Application.WorksheetFunction.CountBlank(PR1) = 0 'boucle jusqu'à ce que la plage PR1 ne contienne aucune cellule vide
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set PR1 = PR1.Resize(PR1.Rows.Count, PR1.Columns.Count - 1) 'redéfinit PR1 sans la dernière colonne (génère une erreur PR1 est vide)
If Err <> 0 Then 'condition 2 : si une erreur a été générée
Err.Clear 'supprime l'erreur
GoTo suite1 'va à l'étiquette "suite1"
End If 'fin de la condition 2
On Error GoTo 0 'annule la gestion des erreurs
Loop 'boucle
End If 'fin de la condition 1
'rajout de la plage au tableau des rectangles
NC = Application.WorksheetFunction.CountA(PR1) 'définit le nombre de cellules NC de la plage PR1
ReDim Preserve TR(1, I) 'redimensionne le tableau TR
TR(0, I) = PR1.Address(0, 0) 'récupère l'adresse de la plage PR1 dans la ligne 0 de TR
TR(1, I) = NC 'récupère le nombre de cellules de la plage PR1
I = I + 1 'incrémente I
suite1: 'étiquette
'définition d'un rectangle sans cellule vide au milieu (horizontal)
Set PR2 = IIf(CEL.End(xlDown).Row > DL, Range(CEL, Cells(CEL.Row, DL)), Range(CEL, CEL.End(xlDown))) 'définit la plage PR2
Set PR2 = IIf(PR2.End(xlToRight).Column > DC, Range(PR2, Cells(CEL.Row, DC)), Range(PR2, CEL.End(xlToRight))) 'redéfinit la plage PR2
If Application.WorksheetFunction.CountBlank(PR2) <> 0 Then 'condition 1 : si la plage PR2 contient des cellules vides
Do Until Application.WorksheetFunction.CountBlank(PR2) = 0 'boucle jusqu'à ce que la plage PR2 ne contienne aucune cellule vide
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set PR2 = PR2.Resize(PR2.Rows.Count - 1, PR2.Columns.Count) 'redéfinit PR2 sans la dernière colonne (génère une erreur quand PR2 est vide)
If Err <> 0 Then 'condition 2 : si une erreur a été générée
Err.Clear 'supprime l'erreur
GoTo suite2 'va à l'étiquette "suite2"
End If 'fin de la condition 2
On Error GoTo 0 'annule la gestion des erreurs
Loop 'boucle
End If 'fin de la condition 1
If PR1.Address = PR2.Address Then GoTo suite2 'si les plages sont identiques, va a l'étiquette "suite2"
'rajout de la plage au tableau des rectangles
NC = Application.WorksheetFunction.CountA(PR2) 'définit le nombre de cellules NC de la plage PR1
ReDim Preserve TR(1, I) 'redimensionne le tableau TR
TR(0, I) = PR2.Address(0, 0) 'récupère l'adresse de la plage PR2 dans la ligne 0 de TR
TR(1, I) = NC 'récupère le nombre de cellules de la plage PR
I = I + 1 'incrémente I
suite2: 'étiquette
Next CEL 'prochaine cellule de la plage
'modifie les plage de TR incluses dans d'autres pour les renvoyer en bas de tableau après le tri
For I = 0 To UBound(TR, 2) 'boucle 1 : sur toutes les plage de rectangle du tableau TR
For J = 0 To UBound(TR, 2) 'boucle 2 : sur toutes les plage de rectangle du tableau TR
If J <> I Then 'condition 1 : si la variable j est différente de I
If Not Application.Intersect(O.Range(TR(0, I)), O.Range(TR(0, J))) Is Nothing Then 'condition 2 : si les deux plages ont des cellules en commun
'condition 3 : si la plage de boucle 2 est incluse dans la plage de la boucle 1
If Application.Union(O.Range(TR(0, I)), O.Range(TR(0, J))).Address = O.Range(TR(0, I)).Address Then
TR(0, J) = "A1:A2": TR(1, J) = 0 'redéfinit la plage de la boucle 2 (n'importe laqelle hors de CNV), redéfinit le nombre de cellules de la plage
End If 'fin de la condition 3
If TR(0, I) <> TR(0, J) Then 'condition 4 : si les plages sont différentes (je ne sais plus pourqoi j'ai mis cette condition...)
'condition 5 : si la plage de boucle 1 est incluse dans la plage de la boucle 2
If Application.Union(O.Range(TR(0, I)), O.Range(TR(0, J))).Address = O.Range(TR(0, J)).Address Then
TEST = True 'définit la varaiable TEST
End If 'fin de la condition 5
End If 'fin de la condition 4
End If 'fin de la condition 2
End If 'fin de la condition 1
Next J 'prochaine plage de la boucle 2
'si TEST est [VRAI],redéfinit la plage de la boucle 1 (n'importe laqelle hors de CNV), redéfinit le nombre de cellules de la plage, redéfinit TEST
If TEST = True Then TR(0, I) = "A1:A2": TR(1, I) = 0: TEST = False
Next I 'prochaine plage de la boucle 1
'tri du tableau TR
For I = 0 To UBound(TR, 2) 'boucle 1 : sur tous les nombre de cellules du tableau TR
For J = 0 To UBound(TR, 2) 'boucle 1 : sur tous les nombre de cellules du tableau TR
If TR(1, J) < TR(1, I) Then 'condition : si la valeur de la boucle 2 est inférieure à la valeur de la boucle 1
T0 = TR(0, J): T1 = TR(1, J) 'récupère les valeur de la boucle 2 dans les variable T0 et T1
TR(0, J) = TR(0, I): TR(1, J) = TR(1, I) 'remplace les valeurs de la boucle 2 par celles de la boucle 1
TR(0, I) = T0: TR(1, I) = T1 'remplace les valeur de la boucle 1 par celles des variables T0 et T1
End If 'fin de la condition
Next J 'prochain nombre de cellules de la boucle 2
Next I 'prochain nombre de cellules de la boucle 1
'revoi du top 10 à partir de la cellule T35
For I = 1 To 10 'boucle de 1 à 10
O.Cells(34 + I, 20) = "Rang " & I 'renvoie le rang en colonne T
O.Cells(34 + I, 21) = TR(0, I - 1) 'renvoie l'adresse du rectangle en colonne U
O.Cells(34 + I, 22) = TR(1, I - 1) 'ernvoie le nombre de cellules en colonne v
Next I 'prochaine valeur de la boucle
End SubBonjour,
Ma (première) contribution :
- Lancement après sélection de la zone de recherche des rectangles.
- Recherche par boucle colonnes-lignes puis boucle lignes-colonnes
- Rectangles trouvés stockés en dictionnaire (élimination doublons)
- Tri et affichage résultats.
- Le reste est de la mise en forme (à améliorer).
Il me reste un bogue à détecter : le programme devrait se limiter à la zone sélectionnée (même entourée de cellules non vides), or la recherche déborde (au moins dans un sens), mais je n'ai pas le temps de chercher la raison dans l'immédiat...
Cordialement.
Bonjour Thau Thème
Tout d'abord je te rmercie pour tous.
J'ai pas eu de l'occasion de tester et d'analyser détaillé ton code mais je suis sur que ça fonctionnera impeccable.
Etant donné que toutes les conditions sont totalement changées dans ma secteur, on a décidé que tous les projets en cours s'arretent jusqu'à ce que l'on puisse gagner un espoir pour le futur.
En tout cas, Merci mille fois à toi.
Nota : Mon niveau français n'est pas suffisant pour comprendre "Me*** trop tard !".......
Bonjour le fil, bonjour le forum,
P... c'est dl'a balle ton code !... Désolé d'être autant de mauvaise foi mais je demande un contrôle anti-dopage ! Ce qui me console c'est qu'on ait les mêmes résultats...
Bonjour MFerrand,
Dans ma premiere occasion, je vais tester ton code et je vais certainement faire un retour (positif ou négatif)...
de maintenant , Je te remercie pour ta réactivité..
Cordialement
Bonsoir le Forum , ThauThème et MFerrand
@ThauThème et @MFerrand
Désolé pour le retour en peu tard. J'avais pas eu de temps pour tester vos codes.
Je viens de les tester.
Aujourd'hui , Malgré que j'ai vecu un jour tellement difficile, je suis tres heureux de vos contributions pour la résolution de mon problème.
Je vous remercie pour vos efforts depensés avec un grand patient.
Mon problème est completement resolu grace à vous.
@ThauThème
J'ai pas encore testé les codes dans le post envoyé à 16:24. mais j'ai testé le code envoyé à 13:41. Ça fonctionne perfectement. Un grand Bravo.. Des que je teste les dernieres codes je ferai un retour. Merci pour tous.
@MFerrand
Bravo à toi aussi. Quand on choisi la totalité de zone (B3:Q15) les codes fonctionnent Super. il ya quelques petit problèmes lors de la selection une zone se situant dans la zone complete. Mais pour moi ça me fait rien car je prendrai en compte toujours la zone complete.
quelques exemples comme les resultats de test
Zone Complete (B3:Q15) : colorisation et listing Super.
C5:L12 .... Colorisation non correcte car il prend en compte les cellules en dehors de la zone selectionnée et le plage selectionné
est B7:O12. Normalement il devra selectionner la zone C7 : L12 qui n'existe pas dans la liste.
B8 : E15.... Colorisation non correcte. Normalement il devra selectionner la zone C8 : E15 qui n'existe pas dans la liste.
D'autre part quand on fait le test consecutif pour quelques differentes zones les listes nouvelles et anciennes sont superposées et quelques parties inutiles restent toujours à qq part.
en tout cas je te remercie pour tous.
Encore une fois Grande MERCI pour vos contributions vraiment professionnelles et incroyables...
Cordialement..
Bonjour à tous,
Un essai. Pour une grande zone, ce sera sans doute une autre affaire, bien que je pense avoir une petite idée pour l'optimisation mais c'est à confirmer. Le code est dans le module de la Feuil1 .
EDIT: Pour MFerrand je n'avais pas réactulisé le fil. Je suis confus et géné
Edit: Bon, après avoir regardé vos résultats, je me suis aperçu que la mise en oeuvre de la méthode par mes soins a été nulle. Pour preuve, j'ai oublié une partie des rectangles. je ne suis plus aussi confus mais très vexé maintenant
Bonjour à tous,
Une version v2 qui prend en compte tous les rectangles (enfin même résultat que MFerrand). La durée d'exécution semble être assez rapide (mais bien moins que la solution MFerrand). Le code est dans module1. Il est relativement simple. le code est un tout petit peu commenté.
Bonjour,
moi aussi je l'avais posé de coté car d'autres obligations.
Une autre approche.
Je découpe la plage en rectangles élémentaire (moins d'opérations ensuite puisqu'on travaille avec des blocs).
Chaque rectangle est associé à tous les autres. Si l'intersection nouvelle plage-ancienne plage n'est pas vide et qu'elle s'est agrandie on mémorise (en gros...)
J'ai fait sur un classeur neuf, l'absence de ThisWorkbook dans ton classeur ne m'inspirait pas confiance.
2 constantes à adapter au début.
A tester sur des formes plus biscornues pour voir si tous les cas sont traités.
Option Explicit
Type rect
ref As Range
C1 As Long ' col deb
C2 As Long ' col fin
nbCell As Long
End Type
Sub test()
Const maxRect As Long = 10 ' nombre de meilleurs rectangles mémorisés
Const debogue As Boolean = True ' visu progression
Dim pl As Range, pl2 As Range, plTmp As Range
Dim plag, ajout As Boolean, ok As Boolean
Dim i As Long, j As Long, k As Long
Dim rect(1 To maxRect) As rect, rectTmp As rect, C1 As Long, C2 As Long
Set pl = Range("B3:Q16")
If pl Is Nothing Then Exit Sub
' construction des blocs de cellules
For i = 1 To pl.Rows.Count
If pl2 Is Nothing Then
Set pl2 = pl.Rows(i).SpecialCells(xlCellTypeConstants)
Else
Set pl2 = Union(pl2, pl.Rows(i).SpecialCells(xlCellTypeConstants))
End If
Next i
plag = Split("," & pl2.Address, ",")
For i = 0 To UBound(plag)
' pour chaque area
If plag(i) <> "" Then
Set pl2 = Range(plag(i))
Do
ajout = False
For j = 0 To UBound(plag)
' l'unir aux autres areas et restreindre aux colonnes communes
If plag(j) = "" Then
Set plTmp = pl2
Else
Set plTmp = Intersect(pl2.EntireColumn.Columns, Range(plag(j)).EntireColumn.Columns, Union(pl2, Range(plag(j))))
End If
If Not plTmp Is Nothing Then
If plTmp.Areas.Count = 1 Then
' nouveau rectangle
C1 = plTmp.Column: C2 = plTmp.Column + plTmp.Columns.Count - 1
ok = False
' recherche si sous-rectangle existe
For k = 1 To maxRect
If rect(k).nbCell = 0 Then
' ajouter
ok = True: Exit For
ElseIf C1 = rect(k).C1 And C2 = rect(k).C2 Then ' si même colonnes
If Not Intersect(plTmp, rect(k).ref) Is Nothing Then ' et si intersection non vide
If plTmp.Cells.Count > rect(k).nbCell Then ' et si taille supérieure
' remplacer
ok = True: Exit For
Else
Exit For
End If
End If
End If
Next k
If ok Then
ajout = True ' plage agrandie
If debogue Then plTmp.Select: Stop
' mémoriser
rect(k).C1 = C1
rect(k).C2 = C2
rect(k).nbCell = plTmp.Cells.Count
Set rect(k).ref = plTmp
' trier
Do
ok = True
For k = 1 To maxRect - 1
If rect(k + 1).nbCell = 0 Then Exit For
If rect(k).nbCell < rect(k + 1).nbCell Then
rectTmp.C1 = rect(k).C1: rectTmp.C2 = rect(k).C2: rectTmp.nbCell = rect(k).nbCell: Set rectTmp.ref = rect(k).ref
rect(k).C1 = rect(k + 1).C1: rect(k).C2 = rect(k + 1).C2: rect(k).nbCell = rect(k + 1).nbCell: Set rect(k).ref = rect(k + 1).ref
rect(k + 1).C1 = rectTmp.C1: rect(k + 1).C2 = rectTmp.C2: rect(k + 1).nbCell = rectTmp.nbCell: Set rect(k + 1).ref = rectTmp.ref
ok = False
End If
Next k
Loop Until ok
End If
Set pl2 = plTmp
End If
End If
Next j
Loop Until Not ajout
End If
Next i
' résultat
ReDim plag(1 To maxRect, 1 To 2)
For i = 1 To maxRect
If rect(i).nbCell = 0 Then Exit For
plag(i, 1) = rect(i).ref.Address
plag(i, 2) = rect(i).nbCell
Next i
[U3].Resize(maxRect, 2) = plag
rect(1).ref.Select ' meilleur rectangle
End Suberic
edit : houlaaa, beaucoup de posts non vus, j'aurais dû rafraichir
... et je trouve pareil que vous...
edit 2 : match nul pour le temps MFerrand
Salut Eric et tous,
Je note surtout ton observation de l'absence de ThisWorksbook ! Qui m'avait échappée ! ...J'avais surmonté les difficultés par des suppressions de parties de feuille, Je prêterai un attention plus grande la prochaine fois.
Pas eu le temps de m'y remettre, je suis en déplacement ces jours-ci... Je reprendrai les points que j'ai à remettre en chantier (que sakman à également observé). MaPoire, pas de souci...
Bonne fin de semaine.