Makro för att slumpmässigt sortera namn

[Pelle.A]

Jag skulle vilja göra ett makro som ur en namnlista gör en ny namnlista, men med namnen i slumpmässig ordning. Principen är alltså:

Börja kopiera listan men i slummässig ordning genom att:

• Välja ut ett namn slumpmässigt

• Kontrollera att namnet inte redan är utvalt (vilket det inte kan vara i första raden, men senare). Detta bör nog ske genom att kontrollera att ett unikt namn inte förekommer två gånger i den nya listan. Om namnet är upptaget ska makrot gå tillbaka till föregående punkt.

• Gå till nästa rad och göra om proceduren

• Avsluta när alla namn är utvalda.

 

 

Men hur gör man ett sådant makro? Jag antar att man enklast jobbar i VBA.

 

Tacksam för tips

 

//Pelle.A

 

 

[PerboMan]

Ett snarlikt problem har diskuterats i denna tråd:

//eforum.idg.se/viewmsg.asp?EntriesId=814390

 

/Pär B

 

[Pelle.A]

Tack för tipset. Fast det löste inte problemet riktigt, jag har redan kollat och testat bl.a. cirkelreferenser. Det fungerar inte helt tillfredställande. Kanske jag skulle lagt frågan i forumet VBA då det ju egentligen är koden för att uträtta sorteringen jag är ute efter.

 

//Pelle A.

 

[Monshi]

VBA eller Excel - de som ka hjälpa läser båda... Om den passar bättre i VBA lovar jag att flytta den dit...

 

Ok, jag gör det.

 

Men - till frågan.

Jag skulle göra det i en annan ordning:

1: Kopiera ut unika namn från list. (finns verktyg för det)

2: Skriva in ett slumptal (enkelt)

3: Sortera. (normal sortering)

4: Radera slumptal.

 

Klart.

 

Kod? Kanske senare...

 

/T

Moderator för Excel & ...

 

[Monshi]

Kanske något likt detta:

[color="#0000ff"]Option Explicit[/color]
[color="#0000ff"]Sub[/color] CopyUniqueSort()

    [color="#0000ff"]Dim[/color] rnSource As Range, rnTarget As Range
    [color="#0000ff"]Dim[/color] myCell As Range
    [color="#006400"]'sätt källan, specificera gärna även arbetsbladet[/color]
    [color="#0000ff"]Set[/color] rnSource = Range([GRÅ]"A1"[/GRÅ], Range([GRÅ]"a1"[/GRÅ]).[color="#0000ff"]End[/color](xlDown))
    [color="#006400"]'samma med målet[/color]
    [color="#0000ff"]Set[/color] rnTarget = Range([GRÅ]"D1"[/GRÅ])
    [color="#006400"]'snabbar upp det hela om inte skärmen[/color]
    [color="#006400"]'måste ritas om.[/color]
    [b]Application[/b].ScreenUpdating = [color="#0000ff"]False[/color]
    [color="#006400"]'rensar först målet. Ok, kanske inte hela[/color]
    [color="#006400"]'kolumnen måste tömmas, se nedan för annan teknik[/color]
    rnTarget.EntireColumn.Clear
    [color="#006400"]'sortera ut unika[/color]
    rnSource.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rnTarget, Unique:=[color="#0000ff"]True[/color]
    [color="#006400"]'initiera slumptal[/color]
    [color="#0000ff"]Randomize[/color]
    [color="#006400"]'skriv slumptal[/color]
    [color="#0000ff"]For[/color] [color="#0000ff"]Each[/color] myCell [color="#0000ff"]In[/color] Range(rnTarget, rnTarget.[color="#0000ff"]End[/color](xlDown))
        myCell.Offset(0, 1) = [color="#0000ff"]Rnd[/color]
    [color="#0000ff"]Next[/color] myCell
    [color="#006400"]'sortera på slumptal[/color]
    Range(rnTarget, rnTarget.Offset(0, 1).[color="#0000ff"]End[/color](xlDown)).Sort Key1:=rnTarget.Offset(0, 1)
    [color="#006400"]'radera slumptal[/color]
    Range(rnTarget.Offset(0, 1), rnTarget.Offset(0, 1).[color="#0000ff"]End[/color](xlDown)).Clear
    [color="#006400"]'glöm inte[/color]
    [b]Application[/b].ScreenUpdating = [color="#0000ff"]True[/color]
[color="#0000ff"]End[/color] [color="#0000ff"]Sub[/color]

 

 

Hänger du med?

 

/T

 

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

 

 

[inlägget ändrat 2006-10-02 21:40:06 av Monshi]

[PerboMan]

OK, jag tyckte bara att det kanske inte måste vara ett makro, fast om det är något du skall göra många gånger så...

En möjlig lösning är:

1. Läs in alla namn i en tvådimensionell matris.

2. Loopa igenom matris så att du slumpmässigt plockar ett namn åt gången till en ny matris. Varje namn som plockats märks så att men kan köra ett nytt slumptal i så fall.

3. Skriv matrisen till kalkylbladet.

 

Anta att du har den ursprungliga namnlistan i kolumn A på Blad1, och vill ha resultatet i kolumn A I Blad2. Namnnlistan måste vara avslutad med en tom cell.

[color="#0000ff"]Sub[/color] Slumpad_lista()
 RadRäknare = 1
 [color="#0000ff"]Do[/color]
  RadRäknare = RadRäknare + 1
 [color="#0000ff"]Loop[/color] [color="#0000ff"]While[/color] Worksheets([GRÅ]"Blad1"[/GRÅ]).Cells(RadRäknare, 1). _
 Value <> 0
 Antal_Namn = RadRäknare - 1
 [color="#0000ff"]ReDim[/color] Namn_Lista(Antal_Namn, 2)
 [color="#0000ff"]For[/color] F = 1 [color="#0000ff"]To[/color] Antal_Namn
  Namn_Lista(F, 1) = Worksheets([GRÅ]"Blad1"[/GRÅ]).Cells(F, 1).Value
 [color="#0000ff"]Next[/color]
 [color="#0000ff"]ReDim[/color] Resultat_Lista(Antal_Namn)
 Valda_Namn = 0
 [color="#0000ff"]Randomize[/color]
 [color="#0000ff"]Do[/color]
  Valt_Namn = Int([color="#0000ff"]Rnd[/color]() * Antal_Namn) + 1
  [color="#0000ff"]If[/color] Namn_Lista(Valt_Namn, 2) = 0 [color="#0000ff"]Then[/color]
   Valda_Namn = Valda_Namn + 1
   Resultat_Lista(Valda_Namn) = Namn_Lista(Valt_Namn, 1)
   Namn_Lista(Valt_Namn, 2) = 1
  [color="#0000ff"]End[/color] [color="#0000ff"]If[/color]
 [color="#0000ff"]Loop[/color] [color="#0000ff"]While[/color] Valda_Namn < Antal_Namn
 [color="#0000ff"]For[/color] F = 1 [color="#0000ff"]To[/color] Antal_Namn
  Worksheets([GRÅ]"Blad2"[/GRÅ]).Cells(F, 1) = Resultat_Lista(F)
 [color="#0000ff"]Next[/color]
[color="#0000ff"]End[/color] [color="#0000ff"]Sub[/color]

 

/Pär B

 

Och så var man där igen, där man glömde att uppdatera...

 

[inlägget ändrat 2006-10-02 21:45:14 av PerboMan]

[inlägget ändrat 2006-10-02 21:49:07 av PerboMan]

[inlägget ändrat 2006-10-02 21:49:48 av PerboMan]

Det verkar vara helt slumpmässigt hur eforum hanterar Kod-taggen och indent.

[inlägget ändrat 2006-10-02 21:50:59 av PerboMan]

[Monshi]

Det verkar vara helt slumpmässigt hur eforum hanterar Kod-taggen och indent.

Nej ingen slump. Kod-motorn är "inaktiverad" men uppdaterar man ett inlägg så...

 

Två lösningar på ett problem är bättre än ingen

 

/T

 

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

 

[MH2]

AdvancedFilter i ett makro var en nyhet, snygg lösning.

 

[Pelle.A]

Tack!

 

Underbart, det funkade perfekt. Ska prova Per B:s lösning oxå. Nu funkar det iallafall, nästa steg är att utifrån denna kod skapa en FUNKTION i Excel som utifrån en namnlista e.d. slumpar ut alla eller ett begränsat antal namn i ett förbestämt område (använda källområdet och målområdet som argument). Men det ska jag klura på med mina ytterst begränsade kunskaper i VBA...

 

Stort tack till er båda!

 

//Pelle A.

 

[Monshi]

AdvancedFilter i ett makro var en nyhet, snygg lösning

 

tackar. Bara ta den gamla vägen för att få det att fungera. Det vill säga - spela in ett makro, göra koden dynamisk och lägg till lite...

 

 

/T

 

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

 

[Monshi]

Skapa en funktion som gör detta är nog svårt....

fast intressant...

 

Något likt detta:

[log]

[color="#0000ff"]Option Explicit[/color]

[color="#0000ff"]Function[/color] GetUnique(rnSource As Range, rnExist As Range) As [color="#0000ff"]String[/color]
    [color="#0000ff"]Dim[/color] maxRows As Long, index As Long
    [color="#0000ff"]Dim[/color] i As Long
    [color="#0000ff"]Dim[/color] temp As Integer
    [color="#0000ff"]Dim[/color] myCell As Range
    [color="#0000ff"]Dim[/color] hit As Boolean

    maxRows = rnSource.Rows.Count
    [color="#0000ff"]Dim[/color] arrRandom() As Variant
    [color="#0000ff"]ReDim[/color] arrRandom(maxRows - 1)
    [color="#0000ff"]Randomize[/color]
    temp = -1
    [color="#006400"]'tar fram UNIKA slumptal[/color]
    [color="#0000ff"]For[/color] index = 0 [color="#0000ff"]To[/color] maxRows - 1
        [color="#0000ff"]While[/color] temp < 0
            temp = Int((maxRows * [color="#0000ff"]Rnd[/color]) + 1)
            hit = [color="#0000ff"]False[/color]
            [color="#0000ff"]For[/color] i = 0 [color="#0000ff"]To[/color] index
                [color="#0000ff"]If[/color] arrRandom(i) = temp [color="#0000ff"]Then[/color]
                    hit = [color="#0000ff"]True[/color]
                [color="#0000ff"]End[/color] [color="#0000ff"]If[/color]
            [color="#0000ff"]Next[/color] i
            [color="#0000ff"]If[/color] hit = [color="#0000ff"]False[/color] [color="#0000ff"]Then[/color]
                arrRandom(index) = temp
            [color="#0000ff"]Else[/color]
                temp = -1
            [color="#0000ff"]End[/color] [color="#0000ff"]If[/color]
        [color="#0000ff"]Wend[/color]
        temp = -1
    [color="#0000ff"]Next[/color] index
    hit = [color="#0000ff"]False[/color]
    [color="#006400"]'söker efter unikt namn[/color]
    [color="#0000ff"]For[/color] index = 0 [color="#0000ff"]To[/color] maxRows - 1
        [color="#0000ff"]For[/color] [color="#0000ff"]Each[/color] myCell [color="#0000ff"]In[/color] rnExist
            [color="#0000ff"]If[/color] myCell = rnSource.Cells(arrRandom(index), 1) [color="#0000ff"]Then[/color]
                hit = [color="#0000ff"]True[/color]
            [color="#0000ff"]End[/color] [color="#0000ff"]If[/color]
        [color="#0000ff"]Next[/color] myCell
        [color="#0000ff"]If[/color] hit = [color="#0000ff"]False[/color] [color="#0000ff"]Then[/color]
            GetUnique = rnSource.Cells(arrRandom(index), 1)
            [color="#0000ff"]Exit[/color] [color="#0000ff"]Function[/color]
        [color="#0000ff"]End[/color] [color="#0000ff"]If[/color]
        hit = [color="#0000ff"]False[/color]
    [color="#0000ff"]Next[/color] index

[color="#0000ff"]End[/color] [color="#0000ff"]Function[/color]

[/log]

Ett STORT problem är dock att funktionenkan räkns om när du minst anar det.. nej, den verkar bara räknas om vid ändring av "bevakade" områden...

 

Ja, använd den såhär:

1: Kopiera in den i en modul i din arbetsbok.

2: Använd den som en vanlig funktion där

rnSource sätts till käll-listan.

rnExist sätts till de namn som redan blivit utsorterade.

Ett exempel

Lista i A1:A6

Formel i E2:

=getUnique($A$1:$A$6;$E$1:E1)

E1 är tom.

Kopiera formeln nedåt.

Klart. Mmh, detta var kul! Något mer problem?

 

 

/T

 

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

 

 

[inlägget ändrat 2006-10-02 23:49:04 av Monshi]

 

[inlägget ändrat 2006-10-02 23:49:34 av Monshi]

[Monshi]

 

UPDATE

Fungerade visst inget bra om det fanns tal i det som skulle utsorteras. Nåja, enkelt löst när man sett problemet.

Lägg till .Text på referensen vid jämförelsen dvs

If myCell.Text = rnSource.Cells(arrRandom(index), 1).Text Then

 

 

/T

 

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