Filter een array met 2 elementen en een wildcard

[cow18]

hoe zou je binnen een array van bv. 50.000 elementen, stel bijvoorbeeld dat ieder element een string van 10 willekeurige karakters A-Z is, die een elementen kunnen uitsluiten met 2 letters bijvoorbeeld B en S.
normaal doe je zoiets met 1 element Arr1=filter(Arr,"B",0,0)
dus de 2 in een OF zou dit zijn Arr1=filter(filter(Arr,"B",0,0),"S",0,0)
Maar ik wil enkel die strings uitlstuiten waar beiden in staan, dus een EN !
Een wildcard wil hij niet aanvaarden

Arr1=filter(Arr,"B*S",0,0)

(nog eventjes vergeten dat ik ook de "S*B" zou moeten langlopen)

 

[JEC.]

Dit is een manier

Sub jec()
 Dim ar, sq, i As Long, x As Long
 ar = Cells(1).CurrentRegion
 ReDim sq(UBound(ar), 0)
 
 For i = 1 To UBound(ar)
    If InStr(ar(i, 1), "B") * InStr(ar(i, 1), "S") Then
       sq(x, 0) = ar(i, 1)
       x = x + 1
    End If
 Next
 
 Cells(1, 4).Resize(x) = sq
End Sub

 

[JEC.]

Of deze omzetten naar VBA, met evaluate

=FILTER(A1:A4;PRODUCTMAT(--ISGETAL(VIND.ALLES({"B"\"S"};A1:A4));{1;1})>1)

 

[cow18]

ik heb ergens een "ARR", een 1D-array van 50.000 elementen
Daar doe ik een zo'n EN filter op en die levert mij een "FL", een 1D-array van bv. 3.000 elementen op
In die kleine loop op het laatste van deze macro ga ik ze dan individueel gaan schrappen.
MAAR, dat kost handen vol tijd (60-90 sec), want ik moet meerdere combinaties doen.

Dus ik zoek een oneliner of een korte code (in tijd) die dus
of ARR - (alle combinaties met B en S)
of anders "ARR exclusief B&S" + "ARR met enkel de B's" +"ARR met enkel de S's"
of plan C

Private Sub MesProblemes()     'les combinaison interdits, effacer ces combinaisons de la matrice Arr

     Set Dict1 = CreateObject("scripting.dictionary")     'mon dictionaire
     Dict1.comparemode = vbTextCompare     'comme ce sont des chiffres (indexes), majuscules et miniscules n'est plus important

     a1 = Sheets("Feuil1").ListObjects("TBL_Noms").DataBodyRange.Columns(1).Value     '1ire colonne du liste des personnes
     a2 = Sheets("Feuil1").ListObjects("TBL_Problemes").DataBodyRange.Value     'liste des combinaisons problematiques

     nmb = UBound(Arr)     'nombre de cominaisions de 3 personnes maintenant
     For i = 1 To UBound(a2)     'boucle ce liste des combinaisons problŽmatiques
   Application.StatusBar = "Combinaisons interdits " & i & " / " & UBound(a2) & "     " & Format(UBound(Arr) + 1, "#,###"): DoEvents
                    'dict.RemoveAll
          Fl = Arr     'matrice avec tous les combinaisons
          For j = 1 To UBound(a2, 2)     'boucles les cel***es dans la mme ligne
               If Len(a2(i, j)) > 0 Then     'cel***e n'est pas vide
                    R = Application.Match(Format(--a2(i, j), "00"), a1, 0)    'cherche ce numŽro dans la premire colonne de la liste des personnes
                    If IsNumeric(R) Then     'trouvŽ
                         Dict1(a2(i, j)) = 1     'ajoute au dictionaire
                         Fl = Filter(Fl, "-" & R & "-", 1, 0)     'filtre les combinaisons avec ce numŽro
                    Else
                         MsgBox "ligne " & i & vbLf & "agent inconnu : " & a2(i, j) & vbLf & Join(Application.Index(a2, j, 0), ", "), vbInformation     'si ce nuŽmro n'est pas dans la liste
                    End If
               End If
          Next

          If Dict1.Count > 0 And UBound(Fl) > -1 Then     'il y a des combinaisons ˆ exclure
               For j = 0 To UBound(Fl)     'boucle ces combinaisons
                    Arr = Filter(Arr, Fl(j), 0, 0)     'efface le dans la matrice
               Next
          End If
     Next

     'MsgBox "nombre de combinaisons ŽliminŽ

end sub

 

[cow18]

@JEC, je zou die 50.000 combinaties in een werkblad kopieren die functie er op los laten en het resultaat terug uit lezen ?
ik mag wel geen 2021-365 functies gebruiken, het is nog een oude 2016.

Het idee is misschien nog zo slecht niet, even testen ...

okay, dat wordt hem en dan kan ik ook nog met een advanced filter werken ipv de klassieke autofilter.
Ik post straks een voorbeeldje

 

[cow18]

in combi staan er +38.000 combinaties van 6 elementen uit 20, maar nu wil ik de combinaties die 1, 10, 15 en 17 bevatten elimineren.
Dit doe ik ik deze macro door die combinaties naar gefilterd te kopieren en er een advanced filter op toe te passen.

Eigenlijk heb ik die +38.000 combinaties in geheugen en de resultaat, de gefilterde versie, daarmee wil ik verder werken in het geheugen en dit "noodzakelijk kwaad" zijspongetje is blijkbaar de minst tijdrovende oplossing. Of zie je het anders ?

Sub Test()
        
   t = Timer
   Set sh = Sheets("gefilterd") 'werkblad
     Sheets("combi").Range("C:C").Copy sh.Range("C1") 'kopieer je combinaties naar je werkblad
     t1 = Timer
     With sh.Range("c10").CurrentRegion
          .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=sh.Range("F1:I2"), Unique:=False 'combinatie van 3 AND filters
          Application.DisplayAlerts = False
          .Offset(1).SpecialCells(xlVisible).Delete 'veeg die combinaties
         Application.DisplayAlerts = True
          .AutoFilter
          .AutoFilter
     End With
     MsgBox "klaar in " & Format(Timer - t, "0.0\s") '& vbLf & t1 - t
End Sub

 

[JEC.]

@Cow, je kan de output ook direct in een array lezen. Op dezelfde manier als de eerste code. Dit is bovendien sneller.
De output staat in array "sq"

Sub jec()
 Dim ar, sq, i As Long, x As Long
 ar = Cells(10, 3).CurrentRegion
 ReDim sq(UBound(ar), 0)
 
 For i = 1 To UBound(ar)
    If InStr(ar(i, 1), "-1-") * InStr(ar(i, 1), "-10-") * InStr(ar(i, 1), "-15-") * InStr(ar(i, 1), "-17-") = 0 Then
       sq(x, 0) = ar(i, 1)
       x = x + 1
    End If
 Next
End Sub

 

[cow18]

okay, ik test dat morgen nog eens uit.

 

[JEC.]

Een korter alternatief

Sub jec()
 Dim ar, sq, i As Long, x As Long
 ar = Cells(10, 3).CurrentRegion
 ReDim sq(UBound(ar), 0)
 
 For i = 1 To UBound(ar)
    If Not ar(i, 1) Like "*1*10*15*17*" Then
       sq(x, 0) = ar(i, 1)
       x = x + 1
    End If
 Next
End Sub

 

[cow18]

inderdaad ! veelbelovend ...:love:
zie bijlage, maak alle combinaties van 10 elementen uit 20 en verwijder dan ddie combinaties waar de paren 1,2 1,3 1,4 1,5 1,6 2,6 2,4 2,5 2,6 3,4 3,5 3,6 4,5 4,6 en 5.6 in voorkomen.

Mijn macro doet er dik 7 seconde over over van +187.000 naar 13.000 te komen

Jouw macro voor enkel het eerste paar doet er 0.1 sec over om van +187.000 naar +68.000 te gaan.
Nu eigenlijk nog een lusje bouwen om dat nog 14 keer te herhalen, maar de aantallen verminderen eigenlijk drastisch, dus kan dat geheel misschien binnen de sec afgewerkt worden.
Dus ruw geschat een tiende (?) van de tijd.

 

[JEC.]

Mooizo!:thumb: Ik verwacht inderdaad dat het nog dik binnen de seconde valt

 

[cow18]

even de excelfile er bij gevoegd, het is voor een franstalige site, mijn frans is wel geen 100% meer.
Je hebt 20 agenten in de tabel links, iedere dag moet je een nieuwe unieke ploeg samenstellen van x personen (in Q4), dus is Q4 = 7 dan zijn er 77.520 unieke combinaties van 7 personen uit een poule van 20 personen. Nu mogen bepaalde paren niet samen werken, zie cel F3 = 11,12,13,14,15,16 >>>> dwz 11-12, 11-13, 11-14, 11-15, ... (=15 koppels mogen niet in die 77.520 voorkomen) >>> levert nog 21.450 unieke combinaties op.
Bon, als je de macro laat lopen (op die kalender klikken of CTRL+SHIFT+P), dan is die bij mij in totaal 5 sec bezig en daarvan is er 1 sec om eerst die +77.000 combinaties te maken en die daarna uit te dunnen tot +21.000. Als je dat nog beter gaat uitspitten, dan is inderdaad de helft (0.5 sec) voor het maken van alle combinaties en de andere 0.5 sec voor het uitdunnen, dus uitdunnen = "dik binnen de seconde".:thumb:

zie macro MyCombinations(N,k)

 

[JEC.]

Mooi klusje zo! :d
Het blijft altijd een uitzoekwerk die combinaties

 

[snb]

Ik besteed geen aandacht aan hoe de gegevens in het werkblad terechtkomen.
Alleen de combinatieproduktie en combinatie-uitsluiting komen aan de orde.

De letters kunnen tenslotte vervangen worden door namen.

Sub M_snb()
  On Error Resume Next
  ReDim sn(14)
  ReDim sp(8 * 10 ^ 4)

  For j = 11 To 16
    For jj = j + 1 To 16
      sn(N) = Array(Chr(64 + j), Chr(64 + jj))
      N = N + 1
    Next
  Next

  N = 0
  For j = 1 To 20
    For jj = j + 1 To 20
      For jjj = jj + 1 To 20
        For jjjj = jjj + 1 To 20
          For jjjjj = jjjj + 1 To 20
            For jjjjjj = jjjjj + 1 To 20
              For jjjjjjj = jjjjjj + 1 To 20
                c00 = Chr(64 + j) & Chr(64 + jj) & Chr(64 + jjj) & Chr(64 + jjjj) & Chr(64 + jjjjj) & Chr(64 + jjjjjj) & Chr(64 + jjjjjjj)
                For Each it In sn
                  If InStr(c00, it(0)) * InStr(c00, it(1)) Then Exit For
                Next
                If it(0) <> "" Then
                  If Err.Number <> 0 Then
                    sp(N) = c00
                    N = N + 1
                    Err.Clear
                  End If
                End If
              Next
            Next
          Next
        Next
      Next
    Next
  Next
    
  MsgBox N & vbLf & sp(0) & vbLf & sp(N - 1)
End Sub

Maar natuurlijk is het simpeler de totale verzameling van combinaties van 7 uit 20 eenmalig te maken.
Die lees je dan in vanuit een werkblad, en verwijder je de ongewenste combinaties.
Het niet niet nodig al die 70000 combinaties iedere keer opnieuw te maken.

 

[cow18]

ik dacht dat deze code net iets generieker geschreven is, waarbij je geen last meer hebt van het aantal elementen dat gekozen wordt en dus het aantal loops dat je moet aanmaken.
in die 2e regel "Aux=evaluate(..." heb je het aantal elementen vastgelegd en ook al de 1e combinatie gemaakt (in een 2021-365 zou je daar een Sequence voor gebruiken) en vanaf dan ben je vertrokken.

Dan zat ik eventjes in de problemen of ik een 1D of een 2D-array moest maken, dus ja, het werd een 2D omdat je soms voorbij de +65.000 kan gaan.
Maar die is in een wip wel te vertalen naar een 1D om dan verder te kunnen gaan met de filter-functie.
Maar als je geleidelijk alle combinaties 1 per 1 afloopt, dan dan moet je niet filteren, dan kan je gemakkelijk de laatste naar de gekozen positie verhuizen en de pointer die oorspronkelijk naar de ubound verwees, verlagen.
Ook de oorspronkelijke namen bij de combinaties voegen is in een wip klaar. (we spreken hier over < 1 sec)


Ik denk dat dit een mooie uitbreiding op je combinaties van je website zou kunnen betekenen.

     iCombinations = WorksheetFunction.Combin(N, k)      'possible combinaties
     Aux = Evaluate("=column(offset(a1,,,," & k & "))")    'start, 1st combination
     ReDim ALL(1 To iCombinations, 1 To 1)
     For R = 1 To UBound(ALL)                                 'alle combinaties doorlopen
          For i = LBound(Aux) To UBound(Aux)
               ALL(R, 1) = ALL(R, 1) & Format(Aux(i), "-00")
          Next
          ALL(R, 1) = ALL(R, 1) & "-"
          Aux(k) = Aux(k) + 1
          If Aux(k) > N Then                  'laatste voorbij target !
               For i = k - 1 To 1 Step -1            'voorgaande kolommen aflopen
                    If Aux(i) < N - (k - i) Then     'tot aan die kolom die nog 1 mag opgehoogd worden
                         Aux(i) = Aux(i) + 1         'die kolom 1 ophogen
                         For j = i + 1 To k         'alle volgende kolommen
                              Aux(j) = Aux(j - 1) + 1     'gelijk aan de vorige kolom +1
                         Next
                         Exit For                          'wip uit de loop
                    End If
               Next
          End If
     Next

 

[snb]

@cow

Dank voor de suggestie.
Ik testte hem hier, maar bleek op mijn systeem 4 * langzamer dan de routine die ik in deze draad plaatste.
Ik blijf er nog wel even mee bezig.

BTW:

     k = 7
     aux = Evaluate("column(1:" & k & ")")

 

[cow18]

je komt op dik 21.000 van de +77.000 combinaties uit, vermoedelijk gaat het daar in je testing verkeerd

Zie regel 61, je bent A, ik ben C, daar had je met KL moeten komen ipv KQ
(apart daar van sp is begrensd op 60.000 ivm die transpose, maar dat is nu even het probleem niet)

 

[cow18]

ik heb van je sp een 2D-array gemaakt en al die checks in the last loop er uit gehaald, want ik weet niet voor wat dat dient.
Dan maak je inderdaad ook alle combinaties aan en ben je 36% sneller ttz. 0.06 sec (binnen de foutmarge van die timer-functie), dus je bent sneller maar het haast niet te meten.
Het voordeel van mijn benadering is dat hij gemakkelijk parametreerbaar is, dus 14 elementen uit 20, je hoeft niets aan te passen, je hoeft niet 14 loops en onder een vergrootglas "jjjjjjjjjjjjjjjj" na te tellen op het aantal j's.

 

[snb]

Je vraag bestaat uiit 2 delen:
- hoe maak ik alle combinaties van 7 elementen uit 20 ?
- hoe filter ik een 15-tal ongeldige combinaties eruit ?

In de bijlage
- een macro (M_snb) voor alle combinaties
- een macro (M_snb_ex) voor alle combinaties, aangevuld met markering van ongeldige combinaties.

Omdat het om meer dat 10 elementen gaat, maak ik het liefst gebruik van letters:
- ze nemen slechts 1 positie in
- bij vergelijkingen (replace, instr, filter, etc) zijn ze eenduidig; 1, 11 , 101 zijn dat niet.
- het is niet nodig de resultaten in een 1-dimensionele array te zetten , omdat de filterfunktie voor het uitsluiten van ongeldige combinaties toch niet werkt

 

[snb]

Ik ben naar een snellere/eenvoudigere methode blijven zoeken.

Vooralsnog voldoet de onderstaande daaraan: