Cherche macro Excel pour sélectionner les 6 premiers chiffre
Bonjour forum
Comme dit dans le titre je cherche une macro excel pour sélectionner les 6 premiers chiffre mais sous certaine condition.
J'ai 4 groupes de couleur 1 vert, 1 bleu foncé et deux rouges le groupe vert va de EB à EU, le bleu de GM à HF le premier groupe rouge de HH à IA et le 2ème groupe rouge de RU à SN soit a chaque fois 20 numéros pour chaque groupe et tous a partir de la ligne 14. le but de la macro est de trouver les 6 premiers 1 en jaune dans le fichier en partant de la ligne 14 et vers le bas. Mais attention aux doublons car si j'ai deux fois le même numéro avec un 1 cela ne compte pas pour une sélection. un cas particulier sur le groupe rouge si on a un doublon on priorise celui a gauche soit HH à IA.
Dans mon fichier j'ai un total de 10 numéros et les 6 premiers sont 9-11-3-13-5-14 ça veux dire que tous les 1 en trop doivent être supprimé.
J'espère que j'ai été limpide, merci de m'aider.
Voici le fichier test
Est ce que ceci est correct ?
Sub Selectionner6Premiers()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim plages As Variant
Dim ordreCol() As Long
Dim colIndex As Long
Dim maxLigne As Long: maxLigne = 1000 ' Ajustez si besoin
Dim ligne As Long, col As Long
Dim numero As Variant
Dim dictNum As Object: Set dictNum = CreateObject("Scripting.Dictionary")
Dim dictCell As Object: Set dictCell = CreateObject("Scripting.Dictionary")
Dim nbTrouves As Long: nbTrouves = 0
Dim cell As Range
' Liste des groupes (ordre prioritaire) = EB:EU, GM:HF, HH:IA, RU:SN
plages = Array("EB:EU", "GM:HF", "HH:IA", "RU:SN")
' Construire un tableau avec l'ordre des colonnes à parcourir
For Each plage In plages
Dim startCol As Long, endCol As Long
startCol = ws.Range(Split(plage, ":")(0) & "1").Column
endCol = ws.Range(Split(plage, ":")(1) & "1").Column
If startCol > endCol Then
For colIndex = startCol To endCol Step -1
ReDim Preserve ordreCol(0 To UBound(ordreCol) + 1)
ordreCol(UBound(ordreCol)) = colIndex
Next colIndex
Else
If Not IsArrayAllocated(ordreCol) Then ReDim ordreCol(0)
For colIndex = startCol To endCol
If ordreCol(0) = 0 Then
ordreCol(0) = colIndex
Else
ReDim Preserve ordreCol(0 To UBound(ordreCol) + 1)
ordreCol(UBound(ordreCol)) = colIndex
End If
Next colIndex
End If
Next plage
' Parcours des cellules : ligne 14 ? 1000, colonne par colonne dans l'ordre
For ligne = 14 To maxLigne
For colIndex = 0 To UBound(ordreCol)
col = ordreCol(colIndex)
Set cell = ws.Cells(ligne, col)
If cell.Value = 1 Then
numero = ws.Cells(1, col).Value
If Not dictNum.exists(numero) Then
dictNum.Add numero, True
dictCell.Add cell.Address, True
nbTrouves = nbTrouves + 1
If nbTrouves = 6 Then Exit For
End If
End If
Next colIndex
If nbTrouves = 6 Then Exit For
Next ligne
' Supprimer tous les autres 1
For ligne = 14 To maxLigne
For colIndex = 0 To UBound(ordreCol)
col = ordreCol(colIndex)
Set cell = ws.Cells(ligne, col)
If cell.Value = 1 And Not dictCell.exists(cell.Address) Then
cell.ClearContents
End If
Next colIndex
Next ligne
' Affichage des 6 numéros trouvés
Dim msg As String: msg = "Numéros sélectionnés : " & Join(dictNum.Keys, ", ")
MsgBox msg, vbInformation, "Résultat"
End Sub
' Petite fonction utilitaire
Function IsArrayAllocated(arr As Variant) As Boolean
On Error Resume Next
IsArrayAllocated = IsArray(arr) And Not IsError(LBound(arr)) And LBound(arr) <= UBound(arr)
On Error GoTo 0
End FunctionBonjour,
Voici ci-après une proposition :
J'ai pris la liberté de simplification suivante : puisque les colonnes entre vos "groupes de colonnes" sont vides, elles sont aussi checkées. Cela rend la boucle plus simple, et comme de toute façon elles sont vides cela ne gène pas le programme.
Je n'ai pas bien compris l'objectif final recherché donc il y a une msgbox avec les numéros dans leur ordre d'apparition, puis tous les numéros de la plage sont supprimés, sauf les 10 premiers "1".
Public Sub TrouverNums()
Const MAX_NUMS As Long = 10
Const MIN_ROW As Long = 14: Const MAX_ROWS As Long = 1010
Const MIN_COL As Long = 132: Const MAX_COL As Long = 508
Dim myNums As Object: Set myNums = CreateObject("Scripting.Dictionary")
' using activesheet
Dim sht As Worksheet: Set sht = ActiveSheet
Dim data As Variant
data = sht.Range(sht.Cells(MIN_ROW, MIN_COL), sht.Cells(MAX_ROWS, MAX_COL)).Value
Dim headerNums As Variant
headerNums = WorksheetFunction.Transpose(WorksheetFunction.Transpose(sht.Range(sht.Cells(1, MIN_COL), sht.Cells(1, MAX_COL)).Value))
Dim rowI As Long, colI As Long, valI As Long
For rowI = LBound(data, 1) To UBound(data, 1) Step 6
For colI = LBound(data, 2) To UBound(data, 2)
If data(rowI, colI) = 1 Then
valI = CLng(headerNums(colI))
If Not myNums.Exists(valI) Then
myNums.Add valI, sht.Cells(rowI + MIN_ROW - 1, colI + MIN_COL - 1)
If myNums.Count >= MAX_NUMS Then
GoTo exitLoop
End If
End If
End If
Next colI
Next rowI
exitLoop:
If myNums.Count < MAX_NUMS Then
MsgBox "Seulement " & myNums.Count & "/" & MAX_NUMS & " nombres trouvés", vbCritical, "Fin d'éxécution"
Exit Sub
Else
Application.ScreenUpdating = False
' clean values
sht.Range(sht.Cells(MIN_ROW, MIN_COL), sht.Cells(MAX_ROWS, MAX_COL)).ClearContents
' rewrite
Dim i As Long, strOut As String
For i = 0 To myNums.Count - 1
myNums.Items()(i).Value = 1 ' myNums.Keys()(i)
strOut = strOut & " - " & myNums.Keys()(i)
Next i
Application.ScreenUpdating = True
MsgBox "Les nombres " & VBA.Right$(strOut, Len(strOut) - 3) & " ont été trouvés", vbInformation, "Fin d'éxécution"
End If
End Subma proposition
Sub Selectionner6Premiers()
Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")
Dim c As Range, FA, Plages, i, Colonnes
t = Timer
With ActiveSheet
Set Plages = Intersect(Union(.Range("EB:EU"), .Range("GM:HF"), .Range("HH:IA"), .Range("RU:SN")), .Rows(1))
ReDim Colonnes(1 To Plages.Cells.Count) 'les colonnes utiles
For Each c In Plages.Cells
i = i + 1
Colonnes(i) = c.Column
Next
Set Plages = .Range("EB14:SN1000") 'la plage à chercher
Set c = Plages.Find(1, searchorder:=xlRows)
If Not c Is Nothing Then
FA = c.Address
Do
r = Application.IfError(Application.Match(c.Column, Colonnes, 0), 0) 'bonne colonne
If r > 0 Then
nr = c.Offset(1 - c.Row).Value2 'valeur en ligne 1
b = False
If Len(nr) > 0 Then 'ligne 1 n'est pas vide
b = IsNumeric(nr) And Not Dict.exists(nr) And Dict.Count < 6 'nr n'existe pas encore et ne pas encore 6 valeurs
If b Then Dict(nr) = nr & " : " & c.Address(0, 0)
End If
If Not b Then c.ClearContents
End If
Set c = Plages.FindNext(c)
Loop While c.Address <> FA
End If
Select Case Dict.Count
Case 0: MsgBox "rien"
Case 1: MsgBox Dict.items()(0)
Case Else: MsgBox Timer - t & vbLf & vbLf & Join(Dict.items, vbLf)
End Select
End With
End SubMerci de vos réponses concernant BsAlv la macro mouline je l'ai laissé 5mn et je fais echap et ça bloque sur End If.
Concernant celle de saboh12617 il sagit bien de trouver les 6 premiers pas les 10 et quand vous dites
et comme de toute façon elles sont vides
pas tout a fait elles contiennent une formule excel qui donne 1 ou "" (rien) je ne sais pas si ça change quelque chose!
Sinon ici
il y a une msgbox avec les numéros dans leur ordre d'apparition
bizarrement il me trouve des numéros qui n'existent pas, souvent le 2ème
Evidemment j'ai testé sur mon fichier original qui est construit comme le fichier test
Re,
Concernant celle de saboh12617 il sagit bien de trouver les 6 premiers pas les 10 et quand vous dites
Modifiez la 1e ligne : Const MAX_NUMS As Long = 6
bizarrement il me trouve des numéros qui n'existent pas, souvent le 2ème
Sur votre fichier original que je vous met ci-joint j'ai les nombres dans l'ordre (lecture ligne par ligne de haut en bas). Résultat : 9 - 11 - 3 - 13 - 5 - 14 comme vous l'indiquiez.
Et mes tests vont dans le même sens. Je ne comprends pas le problème. Le fichier réel est-il différent ?
pas tout a fait elles contiennent une formule excel qui donne 1 ou "" (rien) je ne sais pas si ça change quelque chose!
Le code cherche les cellules égales à 1. Mais a priori les colonnes EV, HG, RT n'en contiennent pas. C'est là qu'il y aurait éventuellement de faux positifs.
Par exemple j'ai refais un autre fichier avec votre macro, j'ai mis des 2 sur les colonnes EV, HG, RT avec ou sans ça change rien il serait censé trouver 16-12-10-14-1-5 bon il trouve 12-16-10-14-1-8 c'est surtout que le 8 dans les 4 groupes n'existe pas !
Je met le fichier je n'ai pas exécuté la macro et chercher le 8 fantôme bizarre
Il y a aussi que le faite que le 4ème groupe de RU à SN pour qu'il valide 1 il faut qu'il y soit 2 fois, sur le fichier par exemple ils sont trois le 10 et 16, 12 et là si je supprime manuellement on a le 16-12-10-14-1-5 et plus de 8 fantôme pas tous a fait il y est mais qu'une fois donc il ne compte pas.
L'idéal ce serait de nettoyer RU SN avant d'utiliser votre macro, on supprime le 1er 1 de chaque colonne on garde le 2ème et on supprime tous les autre plus bas.
Sub GarderDeuxieme1()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim col As Long, row As Long
Dim count1 As Long
Dim firstRow As Long: firstRow = 14
Dim lastRow As Long: lastRow = 1064
' Colonnes de RU à SN = colonnes 471 à 490
For col = Range("RU1").Column To Range("SN1").Column
count1 = 0
For row = firstRow To lastRow
If ws.Cells(row, col).Value = 1 Then
count1 = count1 + 1
If count1 = 1 Then
' Supprimer le 1er
ws.Cells(row, col).ClearContents
ElseIf count1 > 2 Then
' Supprimer les suivants
ws.Cells(row, col).ClearContents
End If
End If
Next row
Next col
End SubEt là c'est pile poil !
Il y a juste un couac c'est que toutes mes formules de EV à GK 14 à 1000 et de IB à RT même ligne n'existe plus
Bonjour,
Merci pour vos retours, je crois que j'ai identifié les problèmes. D'abord, si le sujet est résolu, dites-le-moi ça ne sert à rien que j'y passe trop de temps, et vous pouvez ignorer la suite de ce message.
Sinon, je pense que la différence entre votre résultat "attendu" et celui "obtenu" vient de 2 choses :
- Je vous ai dit que le scan est fait en LIGNE PAR LIGNE, DE HAUT EN BAS. Soit EB14 à EC14 à ED14… SN14 à EB20 (changement de ligne) …
Donc c'est pour ça que la macro trouve 12-16-… et non 16-12-…
- Ensuite, je n'ai rien compris à votre histoire de doublons dans les colonnes rouges. Plus que du code, ce serait utile de l'expliquer avec des mots et des exemples concrets. Commencez par définir un "doublon" car a priori même si vos cellules ne contiennent que des "1", ce sont les valeurs en haut qu'on regarde.
Cela explique pourquoi ma macro vous trouve un "8" en dernier chiffre puisqu'il est présent dans votre exemple en $SB$332. Voici ci-après le log du scan pour comprendre la "lecture" :
$SF$20 12
$HW$98 16
$SD$176 10
$HU$206 14
$GM$308 1
$SB$332 8
- Dernier point, je vous le disais par "simplification" on scanne aussi les colonnes EV, HG et RT. Et donc si elles contiennent "1" on risque de fausser le résultat. Votre premier fichier n'était pas représentatif de votre cas réel, c'est essentiel de laisser des données dans les plages à préserver.
En effet en partant de là, pour "nettoyer" votre plage la macro ne s'embête pas : elle clear tout (plage EB14:SN1064) puis réinscrit les "1" dans les cellules voulues. C'est beaucoup plus simple et efficace. Cependant je vous l'indiquais déjà dans mes précédents messages, si vous avez des données à préserver il faut me l'indiquer. Ce n'est pas pour rien que ma macro est plus rapide que celle de @BsAlv, elle fait des concessions.
Ce n'est pas pour rien que ma macro est plus rapide que celle de @BsAlv, elle fait des concessions.
Est ce que ceci est correct ?
Sub Selectionner6Premiers() Dim ws As Worksheet: Set ws = ActiveSheet Dim plages As Variant Dim ordreCol() As Long Dim colIndex As Long Dim maxLigne As Long: maxLigne = 1000 ' Ajustez si besoin Dim ligne As Long, col As Long Dim numero As Variant Dim dictNum As Object: Set dictNum = CreateObject("Scripting.Dictionary") Dim dictCell As Object: Set dictCell = CreateObject("Scripting.Dictionary") Dim nbTrouves As Long: nbTrouves = 0 Dim cell As Range ' Liste des groupes (ordre prioritaire) = EB:EU, GM:HF, HH:IA, RU:SN plages = Array("EB:EU", "GM:HF", "HH:IA", "RU:SN") ' Construire un tableau avec l'ordre des colonnes à parcourir For Each plage In plages Dim startCol As Long, endCol As Long startCol = ws.Range(Split(plage, ":")(0) & "1").Column endCol = ws.Range(Split(plage, ":")(1) & "1").Column If startCol > endCol Then For colIndex = startCol To endCol Step -1 ReDim Preserve ordreCol(0 To UBound(ordreCol) + 1) ordreCol(UBound(ordreCol)) = colIndex Next colIndex Else If Not IsArrayAllocated(ordreCol) Then ReDim ordreCol(0) For colIndex = startCol To endCol If ordreCol(0) = 0 Then ordreCol(0) = colIndex Else ReDim Preserve ordreCol(0 To UBound(ordreCol) + 1) ordreCol(UBound(ordreCol)) = colIndex End If Next colIndex End If Next plage ' Parcours des cellules : ligne 14 ? 1000, colonne par colonne dans l'ordre For ligne = 14 To maxLigne For colIndex = 0 To UBound(ordreCol) col = ordreCol(colIndex) Set cell = ws.Cells(ligne, col) If cell.Value = 1 Then numero = ws.Cells(1, col).Value If Not dictNum.exists(numero) Then dictNum.Add numero, True dictCell.Add cell.Address, True nbTrouves = nbTrouves + 1 If nbTrouves = 6 Then Exit For End If End If Next colIndex If nbTrouves = 6 Then Exit For Next ligne ' Supprimer tous les autres 1 For ligne = 14 To maxLigne For colIndex = 0 To UBound(ordreCol) col = ordreCol(colIndex) Set cell = ws.Cells(ligne, col) If cell.Value = 1 And Not dictCell.exists(cell.Address) Then cell.ClearContents End If Next colIndex Next ligne ' Affichage des 6 numéros trouvés Dim msg As String: msg = "Numéros sélectionnés : " & Join(dictNum.Keys, ", ") MsgBox msg, vbInformation, "Résultat" End Sub ' Petite fonction utilitaire Function IsArrayAllocated(arr As Variant) As Boolean On Error Resume Next IsArrayAllocated = IsArray(arr) And Not IsError(LBound(arr)) And LBound(arr) <= UBound(arr) On Error GoTo 0 End Function
En faite la macro que j'avais mis + couplé a l'autre fonctionnait
Et j'avais rajouté ça à la fin pour être sur.
' Affichage des 6 numéros trouvés
Dim msg As String: msg = "Numéros sélectionnés : " & Join(dictNum.Keys, ", ")
MsgBox msg, vbInformation, "Résultat"Ah parfait, alors super. Bien joué pour avoir trouvé une solution simple et efficace.
Bonne journée