Utjämning av ackumulerad viktning (Excel)

[dkz]

Jag har en nöt att knäcka och skulle helts vilja göra det i en SQL query, men ingen har svarat och misstänker själv att det är näst intill omöjligt. Därför länkar jag nu den till kalkyltråden med större förhoppning på lösning.

 

Här är ursprungstråden (kolla också bifogad bild så blir det not lite tydligare vad jag vill uppnå)

 

//eforum.idg.se/viewmsg.asp?picture=ok&EntriesId=1173968#1173968

 

[bild bifogad 2009-12-14 08:20:13 av dkz]

[Monshi]

Mmh, en nöt att knäcka. Tror mig veta vad du vill men är inte säker.

 

Därför en fråga:

Om du gör detta förhand (för en grupp) hur många steg behövs det innan det blir rätt? Finns det en unik lösning?

 

Vad jag vill antyda är att det är en iterativ process och resultatet är inte alltid unikt, det kan finnas flera möjliga kombinationer som ger det du önskar/kravet du gett.

 

Och pls - definiera matematiskt vad du menar med ackumulerad viktning så att vi inte talar förbi varandra. (och du, kopiera in bilden i denna tråd)

 

Notera att jag, om jag löser detta, löser det antingen med Excel-formler (om det går) eller VBA-kod. Jag berör inte SQL-satser, det är inte min gebit.

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[dkz]

Hej Monshi.

Visst är det kul med lite utmaningar! Läs mina kommentarer...

 

Om du gör detta förhand (för en grupp) hur många steg behövs det innan det blir rätt? Finns det en unik lösning?

Jag vet vara vad jag vill uppnå, inte hur en systemlösning skulle se ut. Resultatet i den bifogade bilden som jag vill uppnå är helt manuellt framtagen.

 

Vad jag vill antyda är att det är en iterativ process och resultatet är inte alltid unikt, det kan finnas flera möjliga kombinationer som ger det du önskar/kravet du gett.

Helt korrekt, eftersom viktningen samt antal rader kommer vara olika för varje dag.

 

Och pls - definiera matematiskt vad du menar med ackumulerad viktning så att vi inte talar förbi varandra. (och du, kopiera in bilden i denna tråd)

Menar att summan av viktningen ska sträva efter att vara så nära 0 som möjlig under så lång tid under dagen. Med ack.viktninging menar jag att jag hela tiden lägger till nytt värde med föregående värde.

 

Notera att jag, om jag löser detta, löser det antingen med Excel-formler (om det går) eller VBA-kod. Jag berör inte SQL-satser, det är inte min gebit.

Jag har gett upp hoppet med SQL, så en vba/Excel lösning är helt ok.

 

 

 

[Monshi]

Viktning -

Du vill matematiskt sortera så att summan av värdena för en dag ligger så nära noll som möjligt så länge som möjligt?

Dvs en serie med värdena

1 1 -2 1 -3 1

får viktningsserien

1 2 0 1 -2 -1

Eller?

 

Jag hajjar inte riktigt grafen.

Är det siffrorna i den röda kolumnen den ordning du vill ha, då har du optimerat den. Är Ackumulerade viktningen som visar resultatet av de värden som finns där nu?

 

Skapa en ny tabell men ett eller två exempel på före och efter. Före i en tabell och efter i en annan.

 

Det är ju en form av sortering som önskas. Kanske går att ordna via formler men troligen via VBA-kod.

 

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[dkz]

Tack för ditt engagemang! Jag ska försöka förtydliga vad tabellen i den bifogade bilden visar.

 

Kolumn 1 (ID):

Är en unik nyckel för resp. rad.

 

Kolumn 2 (Datum):

Aktuell datum för rad.

 

Kolumn 3 (Viktning):

Aktuell viktning för resp. rad.

 

Kolumn 4 (Ny önskad...):

Är den sorteringsordningen jag vill uppnå. Jag har gjord denna helt manuellt men det är detta jag vill uppnå visa formel/VBA.

 

Kolumn 5 (Ack viktning...):

Summerar värden i kolumn 3 utefter den manuella önskade sorteringsorningen i kolumn 4

 

 

Ja, det jag är ute efter är en ny sorteringsordning som sorterar raderna så att värdet för viktning blir så nära 0 under så lång tid som möjligt per dag.

 

Jag hoppas att detta skiner lite ljus över mitt problem.

 

[Monshi]

men om du vill ha nollvärde på viktningen, om jag förstår den korrekt, borde inte sorteringen börja med det minsta värdet, det som skiljer minst från noll?

 

Jag tror inte jag greppat vad du menar med viktning ännu. Om vi tar din önskade ordning förstår jag viktningen som att den borde bli (i serie)

2 3 4 5 3 0 0 1 2

 

vilket inte är i närheten av optimalt och inte alls i närheten till den serie du ger:

2 1 0 2 1 2 0 0 -1

som jag inte fattar hur den skapats.

 

Med andra ord: Hur beräknar du viktningen? Exakt formel tack. för inte kan den vara som jag tror, då skulle en av de optimala serierna (ID-nummer) vara:

7 2 3 8 4 5 9 6 1

med viktningsvärdena i samma ordning:

0 1 1 - 2 1 1 -3 1 2

med ackumuluerade viktningen enligt mig:

0 1 2 0 1 2 -1 0 2

 

Notera en av de optimala. Finns flera lösningar om mitt antagande korrekt.

 

jag vet vad du vill men inte exakt vad som du märker.

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

[dkz]

Monshi, du har helt rätt i ditt antagande, den optimala serie du anger (ID:7 2 3 8 4 5 9 6 1) är precis det jag är ute efter! Sorteringsordningen i den bifogade bilden, är ett hastverk för att försöka förklara vad jag är ute efter. Men tyvärr så förvirrar den nog mer än förklarar, sorry för det. My bad...

 

 

 

[Monshi]

Sådärja. kopiera klistra in i modul. Ändra referensen till det blad du har din tabell på. Tabellen ska finnas med ID i A-kolumnen, datum i B, viktning i C och TOMT i D dit den kommer att skriva. I E2 fyll i denna formel:

=OM(B2<>B1;C2;C2+E1)

och kopiera ned utmed tabellen.

 

Koden:

'rnSource - område att bearbeta
'rnTarget - målcell, första cell där data ska skrivas i. Område i samma storlek som
'           rnSource används
' iStart - sorteringsindex
Function MySorter(rnSource As Range, rnTarget As Range, iStart As Integer) As Integer
   Dim i As Integer
   'lista för värden. Dynamisk för enkelhetens skull
   Dim myList As New Collection
   'lista för radnummer. Samma sortering som myList
   Dim myIndex As New Collection
   Dim myCell As Range
   Dim c As Integer
   Dim oldVal As Integer
   Dim tempVal As Integer

   'hämtar värdena ur givna området
   For Each myCell In rnSource
       myList.Add Item:=myCell.Value
       myIndex.Add myCell.Row - rnTarget.Row + 1
   Next myCell

   'gamla viktningsvärdet. Utgår från nol
   oldVal = 0
   'ett index
   c = -1
   'till listan är tom. Ett element tas bort per varv
   While myList.Count <> 0
       'stegar igenom listan
       For i = 1 To myList.Count
           'om första varvet, spara första värdet
           If c = -1 Then
               c = i
               tempVal = oldVal + myList(i)
           Else
               'annars, jämför tidigare värde med aktuellt värde
               If Abs(tempVal) > Abs(oldVal + myList(i)) Then
                   c = i
                   tempVal = oldVal + myList(i)
               End If
           End If
       Next i
       'spara
       oldVal = tempVal
       'tilldela sorterringsindex
       rnTarget.Cells(myIndex(c), 1) = iStart
       'räkna upp
       iStart = iStart + 1
       'ta bort använda element
       myList.Remove c
       myIndex.Remove c
       c = -1
   Wend
   'returnera sista index
   MySorter = iStart
End Function
Sub MyCaller()
   Dim rnSource As Range
   Dim rnTarget As Range
   Dim rnId As Range
   Dim rnList As Range
   Dim i As Integer
   Dim rwStart As Integer
   Dim idStart As Integer
   idStart = 1

   With Blad1
       'hitta området
       Set rnList = .Range("b2", .Range("b2").End(xlDown))

       rwStart = 1
       'stega  igenom området
       For i = 2 To rnList.Cells.Count
           'bryt ut en dag och arbeta med den
           'jämför värdet/datumet med föregående cell
           If rnList.Cells(i, 1) <> rnList.Cells(i - 1, 1) Then
               Set rnTarget = rnList.Cells(rwStart, 3)
               Set rnSource = .Range(rnList.Cells(rwStart, 2), rnList.Cells(i - 1, 2))
               'sortera aktuella området. Sista index returneras, räkna upp och spara
               idStart = MySorter(rnSource, rnTarget, idStart) + 1
               rwStart = i
           End If
       Next i
       'sista dagen är kvar
       Set rnTarget = rnList.Cells(rwStart, 3)
       Set rnSource = .Range(rnList.Cells(rwStart, 2), rnList.Cells(rnList.Cells.Count, 2))
       MySorter rnSource, rnTarget, idStart
       'sortera på resultatet
       .Range("a1").CurrentRegion.Sort key1:=.Range("d1"), order1:=xlAscending, Header:=xlYes
   End With
End Sub

Lite fulkod, går nog att snygga till.

 

 

ed: Koden uppdaterad med lite hjälptext

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.

 

 

[inlägget ändrat 2009-12-16 09:01:15 av Monshi]

[dkz]

Wow!

Funkar klockrent efter att bytt ut Blad1 till Sheet1 eftersom jag har en eng version av Excel. Nu ska jag bara sätta mig in i koden och förstå vad den gör.

Hade jag kunnat ge dig fler än ett poäng hade jag gjort det!

Stort tack till dig Monshi.

 

[inlägget ändrat 2009-12-15 22:15:48 av dkz]

[dkz]

Hittade en liten grej i din caller som gjorde att den nya ID sorteringsordningen hoppade ett extra steg när datum ändras. ingen direkt bug, men det störde mig.

genom att ta bort +1 i denna rad så blev det inte några hopp i sorteringsorningen.

 

idStart = MySorter(rnSource, rnTarget, idStart) [color="#ff0000"]+ 1[/color]

 

 

[Monshi]

Mmh, ska den bort... ja se, det skulle den.

 

Visar att du förstått vad koden gör, i princip.

 

Är det en lång lista/tabell?

Då kan du alltid snabba upp körningen genom att i koden stänga av beräkningarna temporärt. Kör du koden ofta, lägg in en knapp eller liknande som du kan starta den med.

Det går även att byta ut de fasta referenserna mot en dialog som låter dig välja vilka celler den ska arbeta med...

 

Till exempel.

 

 

/T

 

Even when we know we´ll never find the answers, we have to keep on asking questions.