Recuperateur de sequence si Existante
Bonjour,
Je m'en remet à vos lumières pour le cas suivant.
Avec l'aide de L'excellent Klin89 je suis arrivé à une premiere étape que je voudrai Optimiser
Le Classeur joint qui est fonctionnel, permet de récupérer des séquences si elles existent
consécutivement dans l'ordre ou le désordre
Exemple en choix si je saisie 12,15,18 et bien il me remontera tout les groupes ou 12,15,18 qui seront présent dans le classeur "XLT"
L'amélioration Attendu est que la Macro va également récupéré les Non consécutifs
Exemple 6,10,16 est aussi une séquence valide qui ce doit d'être remonter.
A savoir que les fonds de couleurs sont prépondérant car elle représente le bloc de recherche ainsi que la colonne D "SEQ"
Par avance Merci de votre aide, et de vos suggestions pour avancer sur ce Dossier
Bien cordialement et Merci
Bonsoir barachoie
Dans un premier temps, je procéderai à la suppression des lignes non concernées
A tester sur une copie de ta feuille source:
Option Explicit
Sub test()
Dim a, e, i As Long, x As Range, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
For Each e In Split(Sheets("RANK").Range("b1").Value, ",")
dico(e) = Empty
Next
With Sheets(1).Range("a1").CurrentRegion
a = .Value
For i = 2 To UBound(a, 1)
If Not dico.exists(CStr(a(i, 3))) Then
If x Is Nothing Then
Set x = .Rows(i)
Else
Set x = Union(x, .Rows(i))
End If
End If
Next
If Not x Is Nothing Then x.EntireRow.Delete
Set x = Nothing
End With
End SubLes zones de couleurs correspondent-elles bien aux différentes occurrences de la colonne G
klin89
Bonsoir Klin89
Oui pour la colonne G "Von" mais plus tard dans le processus elles sont susceptibles de revenir mais avec une autre "Seq" colonne D , et pour la suppression ligne pas recommandé car ces datas sont récupérés par la suite pour une autre Analyse.
Tu m'as fortement aidé la première fois et je ne voudrai pas abusé de ton talent Précieux.
Merci infiniment
re barachoie,
Dans la feuille "RANK", il faut nommer la cellule "A4" Formule
Lance cette macro sur une copie de ta feuille source, le résultat souhaité est-il obtenu ?
Pas compris ton histoire de colonne D
Option Explicit
Sub test()
Dim a, e, i As Long, nbreOcc As Byte, x As Range, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
nbreOcc = Evaluate(Range("Formule").Value)
For Each e In Split(Sheets("RANK").Range("b1").Value, ",")
dico(e) = Empty
Next
'la feuille source en 1ère position dans le classeur
With Sheets(1).Range("a1")
a = .CurrentRegion.Value
For i = 2 To UBound(a, 1)
If Not dico.exists(CStr(a(i, 3))) Then
If x Is Nothing Then
Set x = .Rows(i)
Else
Set x = Union(x, .Rows(i))
End If
End If
Next
If Not x Is Nothing Then x.EntireRow.Delete
dico.RemoveAll: Set x = Nothing
a = .CurrentRegion.Value
For i = 2 To UBound(a, 1)
dico(a(i, 7)) = dico(a(i, 7)) + 1
Next
For i = 2 To UBound(a, 1)
If dico.Item(a(i, 7)) <> nbreOcc Then
If x Is Nothing Then
Set x = .Rows(i)
Else
Set x = Union(x, .Rows(i))
End If
End If
Next
If Not x Is Nothing Then x.EntireRow.Delete
Set x = Nothing
End With
End SubBonne nuit
klin89
Klin89 Merci de prendre sur ton temps car je voie l'heure de ton Post je ne peux qu'être admiratif et reconnaissant.
J'ai intégré ta Macro qui supprime bel et bien les non sélectionnés.
C'est la premiere Macro qui reste maintenant aveugle malgré la présence d'une séquence.
Je te joint le fichier pour Tester.
Question : la suppression des lignes n'est t'elle pas contournable car le fait de s'attaquer a la base de donné "XLT" fait
que l'on ne s'autorise plus d'autre Analyse. ( a savoir ma vraie base est > 65000 lignes.
MERCI !!!!!!!
Cordialement et respectueusement
le fichier !!!!
re barachoie,
Pour marquer la distinction entre les différentes zones, il faut donc s'appuyer sur les colonnes D et G
Option Explicit
Sub test()
Dim a, e, i As Long, nbreOcc As Byte, x As Range, dico As Object, txt As String
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
nbreOcc = Evaluate(Range("Formule").Value)
For Each e In Split(Sheets("RANK").Range("b1").Value, ",")
dico(e) = Empty
Next
'la feuille source en 1ère position dans le classeur
With Sheets(1).Range("a1").CurrentRegion
a = .Value
For i = 2 To UBound(a, 1)
If Not dico.exists(CStr(a(i, 3))) Then
If x Is Nothing Then
Set x = .Rows(i)
Else
Set x = Union(x, .Rows(i))
End If
End If
Next
If Not x Is Nothing Then x.EntireRow.Delete
dico.RemoveAll: Set x = Nothing
a = .Value
For i = 2 To UBound(a, 1)
txt = Join$(Array(a(i, 4), a(i, 7)), Chr(2))
dico(txt) = dico(txt) + 1
Next
For i = 2 To UBound(a, 1)
txt = Join$(Array(a(i, 4), a(i, 7)), Chr(2))
If dico.Item(txt) <> nbreOcc Then
If x Is Nothing Then
Set x = .Rows(i)
Else
Set x = Union(x, .Rows(i))
End If
End If
Next
If Not x Is Nothing Then x.EntireRow.Delete
Set x = Nothing
End With
End Subklin89
Merci klin89
ça fonctionne !!!!!
Aurais-tu un moyen pour rendre la premiere Macro plus solide car il me remonte aucune séquence malgré
que c'est là !!!!! a moins que cela marche chez toi?
Exemple j'ai fait 6,12 je voie 4 séquences et lui me remonte aucune séquence
Cordialement
re barachoie,
Une déclinaison du code précédent :
Restitution en feuil1 préalablement créée
Option Explicit
Sub test()
Dim a, b(), e, i As Long, n As Long, j As Long, nbreOcc As Byte
Dim dico As Object, txt As String
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
nbreOcc = Evaluate(Range("Formule").Value)
For Each e In Split(Sheets("RANK").Range("b1").Value, ",")
dico(e) = Empty
Next
With Sheets("XLT").Range("a1").CurrentRegion
a = .Value
b = Application.Transpose(Application.Index(a, 1, 0))
ReDim Preserve b(1 To UBound(a, 2), 1 To UBound(a, 1))
n = 1
For i = 2 To UBound(a, 1)
If dico.exists(CStr(a(i, 3))) Then
n = n + 1
For j = 1 To UBound(a, 2)
b(j, n) = a(i, j)
Next
End If
Next
dico.RemoveAll
ReDim Preserve b(1 To UBound(b, 1), 1 To n)
For i = 2 To UBound(b, 2)
txt = Join$(Array(b(4, i), b(7, i)), Chr(2))
dico(txt) = dico(txt) + 1
Next
ReDim a(1 To UBound(b, 1), 1 To UBound(b, 2) - 1)
n = 0
For i = 2 To UBound(b, 2)
txt = Join$(Array(b(4, i), b(7, i)), Chr(2))
If dico.Item(txt) = nbreOcc Then
n = n + 1
For j = 1 To UBound(b, 1)
a(j, n) = b(j, i)
Next
End If
Next
ReDim Preserve a(1 To UBound(a, 1), 1 To n)
End With
'Restitution
With Sheets("Feuil1").Range("a1")
.CurrentRegion.Cells.Clear
With .Resize(, UBound(b, 1))
.Value = Application.Transpose(Application.Index(b, 0, 1))
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 40
.HorizontalAlignment = xlCenter
End With
If n > 0 Then
With .Offset(1).Resize(UBound(a, 2), UBound(a, 1))
.FormulaLocal = Application.Transpose(a)
.BorderAround Weight:=xlThin
End With
End If
With .CurrentRegion
.Font.Size = 10
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.Columns.AutoFit
End With
End With
Set dico = Nothing
End Subklin89
Klin89 bonjour et Merci pour cette très bonne idée pour ne pas détériorer la data base.
Merci pour le temps que tu as consacré
Reste un dernier détail qui as toutes son importance la remonté capricieuse. je m'explique pour certains chiffres ça marche pour d'autres c'est compliqué malgré l'existence de sequences
Exemple joint 6,12 et bien c'est 0 datas sur mon PC alors que présent. Peux tu voir sur ton PC si tu as des remontés s'il te plait
Merci d'avance
Encore Merci a Klin89.
Est-ce que quelqu'un pourrait m'aider a debuger la macro de la restitution final qui semble capricieuse pour certain chiffres
En effet certain remontent d'autre pas malgrés l'existence de sequence ????
Exemple 6,12 ne remonte pas !!!!
Par Avance Merci
Re,
Une autre façon de procéder :
Option Explicit
Sub test()
Dim a, w(), e, v, x, i As Long, n As Long, j As Long
Dim dico As Object, txt As String, nbreOcc As Byte
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
x = Split(Sheets("RANK").Range("b1").Value, ",")
nbreOcc = Evaluate(Range("Formule").Value)
With Sheets("XLT").Range("a1").CurrentRegion
a = .Value
For i = 2 To UBound(a, 1)
txt = Join$(Array(a(i, 4), a(i, 7)), Chr(2))
If Not dico.exists(txt) Then
Set dico(txt) = CreateObject("Scripting.Dictionary")
dico(txt).CompareMode = 1
End If
ReDim w(1 To UBound(a, 2), 1 To 1)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt)(CStr(a(i, 3))) = w
Next
For Each e In dico.keys
For Each v In dico(e).keys
If IsError(Application.Match(v, x, 0)) Then
dico(e).Remove v
End If
Next
Next
For Each e In dico.keys
If dico(e).Count <> nbreOcc Then
dico.Remove e
End If
Next
End With
'Restitution en Feuil1
Application.ScreenUpdating = False
With Sheets("Feuil1")
.Cells.Clear
With .Range("a1").Resize(, UBound(a, 2))
.Value = a
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Interior.ColorIndex = 44
If dico.Count > 0 Then
n = 1
For i = 0 To dico.Count - 1
For j = 0 To dico.items()(i).Count - 1
With .Offset(n).Resize(UBound(dico.items()(i).items()(j), 2))
.Value = _
Application.Transpose(dico.items()(i).items()(j))
End With
n = n + UBound(dico.items()(i).items()(j), 2)
Next
With .Offset(n - dico.items()(i).Count).Resize(dico.items()(i).Count)
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
End With
n = n + 1
Next
Else
MsgBox "aucune séquence n'a été repérée"
End If
End With
With .UsedRange
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.Columns.AutoFit
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Merci Klin89
Ce dernier code améliore la lecture et je t'en remercie car c'est avec respect
que je receptionne.
Du fait que de manière usuel j'ai enormment de Datas et bien j'aurai tendance
a préservé les fonds de couleurs que genere la macro qui pond l'onglet XLT.
C un point de détail visuel .......
Le rendu de ton Excellent travail est incontestable car
tu l'as mené d'une main de maître et Encore MERCI!!!!
re,
Avec les couleurs associées à chaque clé.
Option Explicit
Sub test()
Dim a, w(), e, v, x, i As Long, n As Long, j As Long
Dim dico As Object, dico1 As Object, txt As String, nbreOcc As Byte
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
Set dico1 = CreateObject("Scripting.Dictionary")
x = Split(Sheets("RANK").Range("b1").Value, ",")
nbreOcc = Evaluate(Range("Formule").Value)
With Sheets("XLT").Range("a1").CurrentRegion
a = .Value
For i = 2 To UBound(a, 1)
txt = Join$(Array(a(i, 4), a(i, 7)), Chr(2))
If Not dico.exists(txt) Then
Set dico(txt) = CreateObject("Scripting.Dictionary")
dico(txt).CompareMode = 1
dico1(txt) = .Cells(i, 7).Interior.ColorIndex
End If
ReDim w(1 To UBound(a, 2), 1 To 1)
For j = 1 To UBound(a, 2)
w(j, UBound(w, 2)) = a(i, j)
Next
dico(txt)(CStr(a(i, 3))) = w
Next
For Each e In dico.keys
For Each v In dico(e).keys
If IsError(Application.Match(v, x, 0)) Then
dico(e).Remove v
End If
Next
Next
For Each e In dico.keys
If dico(e).Count <> nbreOcc Then
dico.Remove e
End If
Next
End With
'Restitution en Feuil1
Application.ScreenUpdating = False
With Sheets("Feuil1")
.Cells.Clear
With .Range("a1").Resize(, UBound(a, 2))
.Value = a
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Interior.ColorIndex = 44
If dico.Count > 0 Then
n = 1
For i = 0 To dico.Count - 1
For j = 0 To dico.items()(i).Count - 1
With .Offset(n).Resize(UBound(dico.items()(i).items()(j), 2))
.Value = _
Application.Transpose(dico.items()(i).items()(j))
End With
n = n + UBound(dico.items()(i).items()(j), 2)
Next
With .Offset(n - dico.items()(i).Count).Resize(dico.items()(i).Count)
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Interior.ColorIndex = dico1.Item(dico.keys()(i))
End With
n = n + 1
Next
Else
MsgBox "aucune séquence n'a été repérée"
End If
End With
With .UsedRange
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.Columns.AutoFit
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Klin89 en un Mot "MERCI" tu es un Champion !!!!
re barachoie,
Dernière version, un dictionnaire suffit contrairement à la solution précédente
Option Explicit
Sub test()
Dim a, b(), w(), e, v, x, i As Long, n As Long, j As Long
Dim dico As Object, txt As String, nbreOcc As Byte
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
x = Split(Sheets("RANK").Range("b1").Value, ",")
nbreOcc = Evaluate(Range("Formule").Value)
With Sheets("XLT").Range("a1").CurrentRegion
a = .Value
For i = 2 To UBound(a, 1)
txt = Join$(Array(a(i, 4), a(i, 7)), Chr(2))
If Not dico.exists(txt) Then
ReDim w(1 To 2)
Set w(1) = CreateObject("Scripting.Dictionary")
w(1).CompareMode = 1
w(2) = .Cells(i, 7).Interior.ColorIndex
Else
w = dico(txt)
End If
ReDim b(1 To UBound(a, 2), 1 To 1)
For j = 1 To UBound(a, 2)
b(j, UBound(b, 2)) = a(i, j)
Next
w(1)(CStr(a(i, 3))) = b
dico(txt) = w
Next
For Each e In dico.keys
For Each v In dico(e)(1).keys
If IsError(Application.Match(v, x, 0)) Then
dico(e)(1).Remove v
End If
Next
Next
For Each e In dico.keys
If dico(e)(1).Count <> nbreOcc Then
dico.Remove e
End If
Next
End With
'Restitution en Feuil1
Application.ScreenUpdating = False
With Sheets("Feuil1")
.Cells.Clear
With .Range("a1").Resize(, UBound(a, 2))
.Value = a
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Interior.ColorIndex = 44
If dico.Count > 0 Then
n = 1
For i = 0 To dico.Count - 1
For j = 0 To dico.Items()(i)(1).Count - 1
With .Offset(n).Resize(UBound(dico.Items()(i)(1).Items()(j), 2))
.Value = _
Application.Transpose(dico.Items()(i)(1).Items()(j))
End With
n = n + UBound(dico.Items()(i)(1).Items()(j), 2)
Next
With .Offset(n - dico.Items()(i)(1).Count).Resize(dico.Items()(i)(1).Count)
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Interior.ColorIndex = dico.Items()(i)(2)
End With
n = n + 1
Next
Else
MsgBox "aucune séquence n'a été repérée"
End If
End With
With .UsedRange
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.Columns.AutoFit
End With
End With
Set dico = Nothing
Application.ScreenUpdating = True
End Subklin89
Merci pour ton implication Klin89.
Tout est perfectible et tu es un perfectionniste donc respect !!!!
Cordialement