"Fiel" <lebl@post2.tele.invalid> skrev i en meddelelse
news:45680df3$0$205$edfadb0f@dread11.news.tele.dk...
> Hej gruppe
>
> Kan I hjælpe mig med dette?
>
> Jeg har en kolonne med indtastede deltagernavne
>
> A
> B
> C
> D
> E
> F
>
> Næste gang jeg skal udskrive arket skal navnene stå
> i en vilkårlig rækkefølge uden de øvrige kolonners rækker
> skifter plads. Næste gang i en ny vilkårlig
> rækkefølge og så fremdeles.
> Det skal helst ske ved tryk på en udløser af en eller
> anden slags.
>
> Jeg håber I kan hjælpe mig, for jeg synes jeg har prøvet alt.
>
> Med venlig hilsen
> Leif B .
>
>
Hej Leif
Her er en VBA løsning.
Elementerne (der her er navne), kan være tal,
tekst eller begge dele. De skal stå i den samme
kolonne, og der må ikke være dubletter iblandt.
Det er kun nødvendigt at angive startcellen, så
finder programmet selv ud af, hvor navnene slutter.
Kolonnen må *kun* bruges til navnene.
1. Kopiér nedenstående kode.
2. Gå til VBA editoren med <Alt><F11>
3. Find dit projekt i projektvinduet
i den venstre del af skærmen. Hvis vinduet
ikke er synligt, kan du få det frem med
<Ctrl>r. Klik på projektet.
4. Vælg menupunktet Insert > Module
5. Indsæt den kopierede kode i det højre vindue.
6. Ret "A2", hvis dine navne starter i en anden celle.
7. Gå tilbage til arket med <Alt><F11>
8. Opret en knap fra værktøjslinjen "Formularer",
og lad den kalde "RandomSequence".
9. Gem projektmappen og du er klar til klikning
Sub RandomSequence()
'Leo Heuser, 25-11-2006
'Elementerne skal stå i den samme kolonne.
Dim Counter As Long
Dim Element As Variant
Dim ElementColl As Collection
Dim FirstCell As String
Dim FirstCellRange As Range
Dim GetElement As Long
Dim OrgRange As Range
Dim OrgRangeValue As Variant
Randomize
FirstCell = "A2"
With ActiveSheet
Set FirstCellRange = .Range(FirstCell)
Set OrgRange = Range(FirstCellRange, _
.Cells(.Rows.Count, FirstCellRange.Column).End(xlUp))
End With
OrgRangeValue = OrgRange.Value
Set ElementColl = New Collection
On Error Resume Next
For Each Element In OrgRangeValue
ElementColl.Add Item:=Element, key:=CStr(Element)
Next Element
On Error GoTo Finito
If UBound(OrgRangeValue, 1) <> ElementColl.Count Then
MsgBox "Duplicates are not allowed."
GoTo Finito
End If
For Counter = LBound(OrgRangeValue, 1) To UBound(OrgRangeValue, 1)
GetElement = Int(Rnd * ElementColl.Count) + 1
OrgRangeValue(Counter, 1) = ElementColl(GetElement)
ElementColl.Remove GetElement
Next Counter
OrgRange.Value = OrgRangeValue
Finito:
If Err.Number <> 0 Then
MsgBox "Unexpected error." & vbNewLine & Err.Description
End If
On Error GoTo 0
End Sub
--
Med venlig hilsen
Leo Heuser
Followup to newsgroup only please.