Element uit Array verwijderen

Status
Niet open voor verdere reacties.
L

Leika

Gebruiker
Lid geworden
14 dec 2018
Berichten
32
Geachte forum-leden,

Hoe kan je een waarde uit een 1D Array verwijderen?
Elementen die ik wegschrijf krijgen een 0 maar deze storen het verdere verloop.
Dus ben ik op zoek om deze nulwaarden te verwijderen uit mijn Array...

Zo maak ik mijn Array :

Code: 
Set lastRow = Range("CELLS2_", Range("CELLS2_").End(xlDown))   
MyArray = Application.Index(Application.Transpose(lastRow), 1, 0)

For x = 1 To sr                                                 
	iLarge = Application.Large(MyArray, 1)              
        [I3].Offset(1, x) = iLarge                          
        MyArray(Application.Match(iLarge, MyArray, 0)) = 0
Next x

Alvast bedankt om dit te lezen,
Leika
 
Laatst bewerkt door een moderator:
Waarden in een Array kan je alleen wijzigen, niet verwijderen.
Je kan dus een array element wel leeg maken als het een string array is.
Of je zorg ervoor dat die 0 waarden er niet in komen.
 
Laatst bewerkt:
Het plaatsen van een voorbeeldbestand is handiger.
 
Dank heren,

In bijlage bestandje...

Mijn doel is dus groepen te maken die in balans staan met elkaar dus met (bijna) zelfde sommen.
Kan nooit 100% lukken maar met enkele methoden vergroot ik de kansen.
Methode 1 werkt goed maar niet bij elke situatie. Maar wat methode 1 niet kan lukt soms wel met methode 2 en andersom...
Alleen die nullen brengen methode 2 soms in de war, vooral bij zoeken naar kleinste waarden.

Na veel weken testen en zoeken ben ik afgestapt met combinaties maken, deze liepen op tot in de miljoenen... en nam soms één uur in beslag.
Nu ben ik beland bij het Partitieprobleem en buiten een paar moeilijkheden blijkt dit goed te lukken.

Klein duwtje in de goede richting zou ik erg appreciëren en alvast bedankt om mee te denken.
Leika

Bekijk bijlage 333356
 
Wat is de zin van de variabele countcells als je hem niet gebruikt ?
 
Dag snb,

CountCells en nog een paar ongebruikte vars staan daar door de 1001 vorige testen...
Alles netjes opruimen doe ik normaal steeds wanneer alles goed werkt!
Daarom gebruik ik altijd Option explicit.

Heb die weg gedaan en mijn probleem blijft bestaan...

Bedankt voor de opmerking
 
Het begin van Main() zoi ik zo aanpakken:

Code: 
Sub M_snb()
    Blad1.Cells(4, 2).CurrentRegion.Columns(1).Sort Blad1.Cells(4, 2), 2
    sn = Blad1.Cells(4, 2).CurrentRegion.Columns(1)
    y = Application.Average(sn) * 4
    
    ReDim sp(3, 3)
    For j = 1 To 4
      sp(0, j - 1) = sn(j, 1)
    Next
    
    
End Sub
 
Dat ziet er inderdaad veel beter uit!

Waar ik nu aan bezig ben is een zeer complex geheel dat ik zwaar onderschat heb.
Zelfs het Knapzakprobleem kon niet steeds optimaal balans leveren.
Voor zover - ik kan volgen - zit ik met twee grote problemen die ik anders moet aanpakken.
Dat is hoe ik die Array terug netjes kan opbouwen in een loop of/en betere manier van zoeken hoe ik naar een dichtstbijzijnde getal in die array kan zoeken zonder daaraan te prutsen.
In bepaalde gevallen moet ik naar een hoger, lager, gelijk getal zoeken tot zelfs drastisch naar het kleinste... (loop daarom SOMS tegen die nullen aan).
Weet weinig af van een array daarom nam ik deze uitdaging aan.

Bedankt voor je code :thumb:
 
Laatst bewerkt door een moderator:
ik kan de bijlage in #4 niet openen, blijkbaar moet ik richting de webmaster (SNB?) kijken.
Zonder voorbeeld zou ik anders met een dictionary werken, daar kan je zo een record verwijderen en dan je array opnieuw aanmaken met de keys of de items.
 
@cow18

Ik ben 'slechts' een eenvoudige moderator en geen webmaster (wie die tekst daar heeft laten staan is me een raadsel).
Wat er met de bijlage is gebeurd kan ik niet zeggen.
Feit is, dat ook ik hem/haar niet geopend krijg.

Ik hang hier de bijlage aan zoals ik hem heb binnengehaald.
 

Bijlagen

  • Forum.xls
    81 KB · Weergaven: 30
Laatst bewerkt:
@snb, bon, eenvoudige moderator, dat is toch al heel wat :thumb:

@Leika, ik kan de gedachtengang niet volledig volgen, maar hier heb je anders al een mogelijkheid.
Anders moet je eens precies uitleggen, hoe het precies moet werken

Code: 
Sub Probeerseltje()
    Dim arr(1 To 10, 1 To 4), Rest(1 To 4), Teller(1 To 4), SCA, sn, i As Integer, i0 As Integer, j As Integer, Som As Long, MaxRest As Double, MyArray
    
    sn = Range("I4:I19")                                             'je gegevens
    Som = Application.Sum(sn) / 4                                    'per kolom gemiddelde van de som gedeeld door 4
    
    Set SCA = CreateObject("system.collections.arraylist")           'aanmaak van een gesorteerde arraylist
    With SCA
        For j = LBound(sn) To UBound(sn)                             'in een loopje al je waarden in je SCA inlezen
            .Add sn(j, 1)
        Next
        .Sort                                                        'sorteren van klein naar groot
        .Reverse                                                     'sortering omkeren = van groot naar klein

        For i = 1 To 4                                               'blijkbaar eerst in iedere kolom de grootste zetten
            Teller(i) = 1                                            'tellertje voor relatieve positie binnen een kolom
            arr(Teller(i), i) = SCA(0)                               'schrijf de grootste waarde in die kolom
            Rest(i) = Som - Application.Sum(Application.Index(arr, 0, i))    'bepaal rest voor die kolom
            .Remove SCA(0)                                           'verwijder de grootste waarde (die je net gebruikt had)
        Next

        Do While .count                                              'loopje zolang er nog waarden in je SCA zitten
            MaxRest = Application.Max(Rest)                          ' bepaal grootste resterende waarde van de 4 kolommen
            i = Application.Match(MaxRest, Rest, 0)                  'het is die kolom
            If MaxRest > SCA(0) Then                                 'is de resterende waarde groter dan de grootste waarde in SCA, dan gebruik je die
                Teller(i) = Teller(i) + 1                            'tellertje binnen die kolom 1 ophogen
                arr(Teller(i), i) = SCA(0)                           'waarde aan kolom toevoegen
                Rest(i) = Som - Application.Sum(Application.Index(arr, 0, i))    'bepalen rest
                .Remove SCA(0)                                       'verwijderen grootste waarde uit SCA
            Else
                MyArray = .toarray                                   'je waarden binnen SCA naar een array schrijven
                i0 = Application.Match(MaxRest, MyArray, -1)         'zoek de waarde, die net groter is dan de restwaarde binnen die array
                Teller(i) = Teller(i) + 1                            'tellertje binnen je kolom +1
                arr(Teller(i), i) = SCA(i0 - 1)                      'waarde aan kolom toevoegen
                Rest(i) = Som - Application.Sum(Application.Index(arr, 0, i))    'bepalen rest
                .Remove SCA(i0 - 1)                                  'verwijderen net toegevoegde waarde uit SCA
            End If
        Loop

    End With
    Range("J4").Resize(UBound(arr), UBound(arr, 2)).Value = arr      'array wegschrijven naar je werkblad
End Sub
 
Een poging.

Zoals ik het heb getest plaats je eerst de vier grootste getallen op rij 1.
Daarna maak je van de vier grootste getallen in de array een 0.
Ik maak daar een tilde van die ik er weer uit filter.

Met de methode 'Filter' wordt Typename van de array een String().
Maar die moet je niet (je kan er niet mee rekenen), dus zet ik het weer om in variant.

Gebruik ook geen variabelen die al vergeven zijn in VBA (Average,Val), ik loop ze niet allemaal bij langs, want Average als variabele doet toevallig in de code niets, maar Val wel, dus aangepast naar Vall).
Code: 
 Public Sub MAIN()
    Dim n, i, result, count, x, t, sr, pa, CountCells, mCol, j, tel,[COLOR=#ff0000]vall[/COLOR], pos As Integer
    Dim posi
    Dim SumCells, [COLOR=#ff0000]Average[/COLOR], MinValue, ave As Long
    Dim iLarge As Integer
    Dim MyArray, MyArray2 As Variant
    Dim lastRow, lastCol As Range
    Dim a, u, r
    
    
    Set lastRow = Range("CELLS2_", Range("CELLS2_").End(xlDown))
    MyArray = Application.Index(Application.Transpose(lastRow), 1, 0)
  
    sr = 4
    pa = 4
   
    For i = 1 To (sr * pa)
        SumCells = (SumCells + Application.Large(MyArray, i))
    Next i
    [AVERAGE_] = SumCells / sr
    CountCells = Application.CountA(MyArray)
    Range("J4:M26").ClearContents


  
    For x = 1 To sr
        'MsgBox "Eerste rij uitvullen"
        iLarge = Application.Large(MyArray, 1)
        [I3].Offset(1, x) = iLarge
[COLOR=#0000ff]        MyArray(Application.Match(iLarge, MyArray, 0)) = "~"[/COLOR]
    Next x
[COLOR=#0000ff]   MyArray = Filter(MyArray, "~", False)[/COLOR]
[COLOR=#0000ff]   ReDim arr(UBound(MyArray))[/COLOR]
[COLOR=#0000ff]
[/COLOR]
[COLOR=#0000ff]    For i = 0 To UBound(MyArray)[/COLOR]
[COLOR=#0000ff]       arr(i) = CDbl(MyArray(i))[/COLOR]
[COLOR=#0000ff]    Next i[/COLOR]
[COLOR=#0000ff]  MyArray = arr[/COLOR]
    For n = 1 To 4 'sr - 1
        
        MyArray2 = [SUM_TOTAL].Resize(1, sr)
       [COLOR=#0000ff] vall [/COLOR]= Application.Small((MyArray2), 1)
        pos = Application.Match(vall, MyArray2, False)
                    
        For x = 1 To pa - 1            'sr * pa - 1
            [COLOR=#0000ff]vall[/COLOR] = [AVERAGE_].Offset(0, pos)
            '[AVERAGE_].Offset(0, pos).Select
            ave = Abs([AVERAGE_] - [COLOR=#0000ff]vall[/COLOR])
            
            t = Application.Max(MyArray)
            For Each r In MyArray
            MsgBox r
                u = Abs(r - ave)
                If u < t Then
                    t = u
                    a = r
                End If
            Next
            MsgBox "Dichtste waarde bij " & ave & " is : " & a
       
            
            posi = Application.Match(a, MyArray, False)
            
            If IsError(posi) Then
               MyArray(posi) = 100000                       ' Absurd, liever een zero gezet maar dan werkt het niet!
            Else
                MsgBox posi & " not found!"
            End If
            
            [CELLS2_].Offset(x, pos) = a
           
        Next x
    Next n
    ' Laat Array zien :
    Dim v As Variant
    For Each v In MyArray
        Debug.Print v
    Next
End Sub

Je moet niet denken dat alle variabelen een Integer zijn zoals genoteerd.
Code: 
Dim n, i, result, count, x, t, sr, pa, CountCells, mCol, j, tel,[COLOR=#FF0000]vall[/COLOR], pos As Integer
Alleen pos is een integer en de rest variant.
Je moet ze dan per variabele aangeven wat ze moeten worden.
Bv.
Code: 
Dim [COLOR=#0000ff]n as long, i as long,[/COLOR] result, count, [COLOR=#0000ff]x as long,[/COLOR] t, sr, pa, CountCells, mCol, j, tel,[COLOR=#FF0000]vall[/COLOR], pos As Integer
Zo zijn de andere niet gedeclareerde variabelen nog steeds variant.
 
@snb, je bent alvast een goede meerwaarde!

Dag Cow18,

Ja, inderdaad goede uitleg geven is ook een kunst… maar ik bezit die niet :eek:
Veel hieronder heb je al begrepen maar kan interessant zijn voor andere mensen.
Bedoeling is dus groepen maken met zelfde som en met zelfde aantal rijen in gebruik.
Je brengt de groepen in balans met de hoogste waarden uit de linker kolom.
De getallen/waarden uit de linkse kolom mogen maar 1x gebruikt worden.

Afwijkingen bij zoeken naar hoogste waarden :
Is de som van de groep hoger dan de average dan zoek je naar de kleinsten om die groep niet hoger te maken.
Er is daarvoor meer keuze wanneer in linkse kolom meer waarden staan dan nodig. Nu is het juist 4x4=16

Gebruiker bepaalt aantal groepen en aantal rijen naar onder.
In mijn voorbeeld kies ik voor 4 groepen en 4 rijen naar onder uitvullen.
Ik mag dus NIET in de ene groep 5 rijen gebruiken en in de andere groep maar 2…

Cow18, ga je nu evenveel rijen gebruiken in elke groep dan breek je wie weet mijn record. :)
Nu moet je weten dat ik daar al maanden zit over te piekeren, pffff
Er bestaan zoveel mogelijkheden…

Knap hoor! Je hebt alvast een deel van het Cutting stock problem opgelost!
Ben nog steeds niet zeker of je hier echt moet beginnen met uitvullen van de hoogste waarden in eerste rij.
Er zullen situaties zijn waar dat niet wenselijk is maar dan wordt het (voor mij) echt ingewikkeld.

Heel erg bedankt voor je probeerseltje en vooral de uitleg erbij!
Ga mij morgen verdiepen in SCA, je brengt mij op het goede spoor, we zien in de verte een lichtje… :shocked:

Groetjes,

Leika
 
Laatst bewerkt door een moderator:
HSV,

Heel erg bedankt voor je poging en zal morgen eens testen of stiekem in de nacht...
Laat zeker nog van mij horen.

Groetjes,

Leika
 
deze doet net hetzelfde als je jouwe, alleen vult hij een 12 ipv een 11 in J7. Ook M6 had je leeg gelaten
Ik heb niet gecheckt wat er het best zou zijn, dat laat ik aan jou voor je zegt dat ik weer een ander probleem opgelost heb:d
Vermoedelijk moet ik een stap vroeger stoppen om geen overshoot te krijgen.
Code: 
Sub Probeerseltje()
    Dim arr(1 To 10, 1 To 4), Rest, SCA, sn, i As Integer, i0 As Integer, j As Integer, Som As Long, MaxRest As Double, ArrAsc, ArrDes, iAsc, iDes, deltaAsc As Double, deltaDes As Double

    sn = Range("I4:I19")                                             'je gegevens
    Som = Application.Sum(sn) / 4                                    'per kolom gemiddelde van de som gedeeld door 4

    Set SCA = CreateObject("system.collections.arraylist")           'aanmaak van een gesorteerde arraylist
    With SCA
        For j = LBound(sn) To UBound(sn)                             'in een loopje al je waarden in je SCA inlezen
            .Add sn(j, 1)
        Next
        .Sort                                                        'sorteren van klein naar groot
        .Reverse                                                     'sortering omkeren = van groot naar klein

        For j = 1 To 4                                               'blijkbaar eerst in iedere kolom de grootste zetten
            arr(1, j) = SCA(0)                                       'schrijf de grootste waarde in die kolom
            .Remove SCA(0)                                           'verwijder de grootste waarde (die je net gebruikt had)
        Next

        For j = 4 To 1 Step -1                                       'kolommen van rechts naar links verder vullen
            For i = 2 To 4                                           'binnen die kolommen, de rijen aanvullen
                Rest = Som - Application.Sum(Application.Index(arr, 0, j))    'bepaal rest voor die kolom
                If Rest > 0 Then                                     'nog niet teveel in die kolom
                    .Sort                                            'sorteren van klein naar groot
                    ArrAsc = .toarray                                'je oplopende waarden binnen SCA naar een array schrijven
                    .Reverse                                         'omkeren = sorteren van groot naar klein
                    ArrDes = .toarray                                'je aflopende waarden naar een array schrijven
                    iAsc = Application.Match(Rest, ArrAsc, 1)        'zoek de waarde, die kleiner of gelijk is dan de restwaarde binnen die array
                    iDes = Application.Match(Rest, ArrDes, -1)       'zoek de waarde die groter of gelijk is
                    deltaAsc = 1000000000#: deltaDes = 1000000000#   'beide deltas heel groot instellen
                    If IsNumeric(iAsc) Then deltaAsc = Abs(Rest - ArrAsc(iAsc - 1)): MsgBox Rest & vbTab & ArrAsc(iAsc - 1)
                    If IsNumeric(iDes) Then deltaDes = Abs(Rest - ArrAsc(iDes - 1)): MsgBox Rest & vbTab & ArrDes(iDes - 1)
                    If deltaAsc <= deltaDes Then
                        .Sort
                        arr(i, j) = SCA(iAsc - 1)                    'waarde aan kolom toevoegen
                        .Remove SCA(iAsc - 1)
                    Else
                        .Sort
                        .Reverse
                        arr(i, j) = SCA(iDes - 1)                    'waarde aan kolom toevoegen
                        .Remove SCA(iDes - 1)
                    End If
                End If
                Range("J4").Resize(UBound(arr), UBound(arr, 2)).Value = arr    'array wegschrijven naar je werkblad
            Next
        Next
    End With

    Range("J4").Resize(UBound(arr), UBound(arr, 2)).Value = arr      'array wegschrijven naar je werkblad

End Sub
in plaats van 2 arrays, een oplopende en een aflopende, had je anders ook binnen 1 array kunnen blijven en dan 1 of enkele posities verder kunnen gaan om die waarde te vinden die net voorbij je streefwaarde zat, maar dat is maar een gedachtengang. Mogelijks maakt dat alles een beetje eenvoudiger, leesbaarder
 
Laatst bewerkt:
Oops, nu snap ik het en voel mij heel schuldig! :eek:

Snel even tussen de middagpauze reageren…
Jullie zijn verder gegaan op mijn code van methode 2; die gaf mij als resultaat nullen en vertikte het om de andere groepen verder uit te vullen.
Om verdere misverstanden te vermijden mijn code hier verwijderd.

In bijlage laat ik in de manuele methode de ideale wereld zien met dozen en appels.
Mijn methode 1 werkt heel logisch maar is te simpel en faalt in deze situatie.
Heb methode 1 dus ook manueel uitgevuld om tot zelfde resultaat/balans te komen als de appels…
De vraag is nu kan dit wel met code zonder miljoenen of miljarden combinaties te hoeven maken?
Met combinaties maken zal het mij lukken en heb ik getest maar daarvoor is Excel veel te traag.
Uren wachten, het lijkt alsof Excel niet alle kernen gebruikt van een processor…

Alvast heel erg bedankt dat jullie meedenken, het zou jammer zijn dat ik maanden of jaren zoek achter iets dat niet mogelijk blijkt in Excel.
Heb nota genomen van jullie opmerkingen!

Groetjes,
Leika

 

Bijlagen

  • Forum.xls
    93,5 KB · Weergaven: 31
Laatst bewerkt door een moderator:
macro "testen"
maak eerst 100 willekeurige getallen tss 100 en 900 aan in kolom A
Zal daarna die 100 getallen proberen toe te kennen op 2 methodes in een 10*10 array.
De niet gebruikte getallen komen te staan in de kolommen E en R.
Die uren zijn herleid tot milliseconden.
 

Bijlagen

  • Forum2.xls
    101 KB · Weergaven: 22
Dag Cow18,

Vraag mij af of ik tegen artificiële intelligentie praat of een mens...
Supersnel.... bij mij een klein 0.023 sec :shocked:

Misschien een test want je gebruikt geen 10 volledige rijen.
Heb mijn cijfers gebruikt en gerangschikt zodat je nog beter idee krijgt wat ik zoek.

Bekijk bijlage Forum2 (1).xls

Wel leuk om te volgen hoe jij als Harry Potter Excel gebruikt, haha!

Groetjes,
Leika
 
soms gebruikt hij inderdaad niet alle rijen, de macro "methode2" nog een keer laten lopen en dan doet hij het waarschijnlijk wel weer goed.
Dan begrijp ik niet wat die divergentie doet.
Ik gooi wat getallen van de ene kolom naar de andere kolom met de macro "swappen2".
Daarmee kan ik de som van de absolute afwijkingen (S3 en AF3) van 234 naar 12 krijgen.
Maar dat is niet helemaal het gevraagde.

Schrijf eens uit wat jouw logica is om naar jouw ideale tabel te gaan uitgaande van de tabel T11:AC20.

Oja, en waarvoor dient dit eigenlijk ? Iets voor nerds ?
 

Bijlagen

  • Forum2 (1).xls
    142,5 KB · Weergaven: 22
Laatst bewerkt:
Dag Cow18,

Inderdaad ben nog steeds diep aan het uitzoeken wat de beste procedure is zonder alle combinaties te hoeven maken.
Van zodra ik iets gevonden heb laat ik het weten.
Ik ga eerst wat meer leren uit je eerste code die zit zo mooi in elkaar en ook eens verdiepen in Collections.
Opmerkingen van HSV ga ik ook eens toepassen op eigen code... wie weet...

Nerds? Hehe
Het begon bij batterijen... wilde weten hoeveel volt je hebt bij x-aantal in serie, parallel en hoe je die aan elkaar moet zetten.
In Excel geef ik aan hoeveel batterijen ik in serie en parallel wil, druk op een knopje en Excel tekent voor mij hoe ik deze moet koppelen, geeft daarbij de voltage, de amperage,...
Daarna kwam het idee om zelf de batterij van mijn fiets te herstellen.
Je koopt oude laptop-batterijen laad die op en meet hoeveel ampère die nog leveren.
Daarna moet je die in groepen sorteren zodat elke groep mooi in evenwicht is en zelfde aantal ampère zal leveren...
Denk je nu groter? Als je ziet hoe snel de energie prijzen de hoogte invliegen is dit een mooi toekomst project wanneer je Off-grid wilt gaan bij zonnepanelen.
Denk daarbij aan de onbetaalbare Tesla batterij(en) aan de muur...
Dit project is dus zeker geen verloren zaak!

Morgen lekker stoeien met je bestandje!

Heel erg bedankt voor je medewerking.

Groetjes,
Leika
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan