Live-Forum - Die aktuellen Beiträge
Datum
Titel
16.04.2024 23:30:16
Anzahl Jahre Zählen aus Datumreihe
16.04.2024 19:22:16
Von exceltabelle in word per steuerelement temarker
16.04.2024 18:50:53
Fehlermeldung bei Code - Excel speichern mit Bez. aus Zelle
16.04.2024 17:18:01
Projektplan-Tabelle oder Gantt ohne Balken
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1552to1556
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1552to1556
1552to1556
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

per Zufall Zelle kopieren (Makro)

per Zufall Zelle kopieren (Makro)
10.04.2017 12:59:52
Andreas
Hallo,
ich möchte gerne einzelne Werte einer Zelle von bspw. Spalte D, Zelle 6-17 nach Spalte B Zelle 6 kopieren/verschieben und das zufällig.
Beim nächsten ausführen des Makros soll die bereits kopierte Zelle (dann ja leer) nicht mehr berücksichtigt werden.
Außerdem soll die zweite zufällig ausgewählte Zelle in Spalte B Zelle 7 kopiert/verschoben werden. Das geht solange bis in Spalte D Zelle 6-17 keine Einträge mehr sind.
Mein Lösungsansatz bisher ist folgender:
Public Sub Zufall()
'Code für ein allgemeines Modul
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngZ As Long
Set wksQ = Worksheets("Tabelle2") '
Vielleicht kann mir hier jemand weiterhelfen. Vielen Dank :-)

13
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 13:22:51
ChrisL
Hi Andreas
Einfacher wäre, wenn du alle Zellen gleichzeitig nach dem Prinzip "Mischen" überträgst. Man würde in einer Hilfsspalte =ZUFALLSZAHL() machen und dann nach dieser Spalte sortieren.
Dennoch, hier der Code gemäss deiner Beschreibung:
Sub t()
Dim rngBereich As Range, rngZelle As Range
Dim letzteZeile As Long
Randomize
With Worksheets("Tabelle1")
Set rngBereich = .Range("D6:D17")
If WorksheetFunction.CountBlank(rngBereich) = rngBereich.Count Then
MsgBox "Keine Werte mehr zum Übertragen vorhanden."
Exit Sub
End If
Set rngZelle = .Cells(Int((12 * Rnd) + 6), 4)
Do Until rngZelle  ""
Set rngZelle = .Cells(Int((12 * Rnd) + 6), 4)
Loop
letzteZeile = .Range("B18").End(xlUp).Row + 1
If letzteZeile

cu
Chris
Anzeige
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 13:54:02
Daniel
Hi
wenns nur die Werte sein sollen, könntest du auch so vorgehen:
1. Werte in ein Array lesen
2. im Array die Werte mischen (z.B. nach dem Prinzip: jeder Wert im Array tauscht seinen Platz mit einem zufällig ausgewähltem Array-Wert)
3. Werte aus dem Array in den neuen Zellbereich zurückschreiben:
Sub Mischen()
Dim arr
Dim x As Long, y As Long
Dim Wert
arr = Range("D6:D17").Value
For x = 1 To UBound(arr, 1)
y = WorksheetFunction.RandBetween(1, UBound(arr, 1))
Wert = arr(x, 1)
arr(x, 1) = arr(y, 1)
arr(y, 1) = Wert
Next
Range("B6").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub
Gruß Daniel
Anzeige
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 13:59:47
Andreas
Hallo, erstmal danke für die schnellen Antworten :-)
Ich würde aber gerne das nicht alle auf einmal kopiert werden.
Im Prinzip wäre es mir am liebsten wenn ich es so hätte:
Klick auf einen Button und ein Wert (bei mir wäre es ein Team) wird aus einer Spalte z.B. D zwischen Zelle 3-14 ausgewählt und in Spalte B Zelle 5 kopiert.
Beim nächsten Klick soll die leere Zelle nicht beachtet werden und eine andere Zelle aus der gleichen Range (Spalte D, Zelle 3-14) in die nächste Zelle (Spalte B, Zelle 6) kopiert werden.
Ich hoffe das ist verständlich :-)
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 14:27:05
Daniel
Hi
dann probiers mal mit diesem Makro, welches bei Buttonklick ausgeführt werden sollte:
Sub Mischen()
Dim x As Long, y As Long
If WorksheetFunction.CountA(Range("D6:D17")) = 0 Then
MsgBox "Keine Werte in Spalte D vorhanden"
Exit Sub
End If
If WorksheetFunction.CountBlank(Range("B6:B17")) = 0 Then
MsgBox "Keine freien Plätze in Spalte B vorhanden"
Exit Sub
End If
With Range("D6:D17").SpecialCells(xlCellTypeConstants, 3)
x = WorksheetFunction.RandBetween(1, .Areas.Count)
y = WorksheetFunction.RandBetween(1, .Areas(x).Cells.Count)
With .Areas(x).Cells(y)
.Copy Range("B6:B17").SpecialCells(xlCellTypeBlanks)(1)
.ClearContents
End With
End With
End Sub

eine Area ist ist ein lückenloser rechteckiger Zellblock.
eine Range kann aus mehrern Areas zusammengesetzt sein.
die Range("D6:D10,D12:D17") besteht aus den beiden Areas "D6:D10" und "D12:D17"
da die Ansprache einer Zelle über den Index nur in einem lückenlosen rechteckigen Zellblock funktionert, musst du spätestes ab dem zweiten Wert die Area auswählen und dann innerhalb der Area die zu kopierende Zelle.
Gruß Daniel
Anzeige
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 15:00:49
Andreas
Klappt soweit perfekt :-) zwei Kleinigkeiten würde ich gerne noch ändern.
Mein erster Versuch sah so aus:
Für jedes Team einen einzelnen Button und dann musste Spalte D immer nach oben kopiert werden. Damit die Range für den nächsten Button kleiner ist.
Was dabei schön war. Die Teams wurden in der Zelle B6 (zweiter Button B7, usw.)angezeigt, nach einer gewissen Zeit stoppte der Timer und das ausgewählte Team wurde zusätzlich in einen extra Fenster angezeigt.
Leider hab ich das Skript gerade nicht hier.
Aber vielleicht weißt du ja was ich meine und kannst mir weiterhelfen :-)
Anzeige
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 15:25:07
Daniel
Hi
das mit dem Nachoben rücken kannst du ja ganz einfach so realisieren, dass du die kopierte Zelle mit .Delete Shift:=xlup löschst. Dann rutschen die folgezellen nach oben nach und du kannst dir das Area-Gedöns sparen:
dim x as Long
with Range("D6:D17").specialCells(xlcelltypeconstants, 3)
x = randbetween(1, .cells.count)
.cells(x).copy Range("B6:B17").SpecialCells(xlCellTypeBlanks)(1)
.Delete Shift:=xlup
end with
was du sonst noch willst, habe ich nicht verstanden.
Gruß Daniel
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 15:46:32
Andreas
Im Prinzip ist das was du mir geschickt hast sehr gut.
Was ich gerne noch hätte ist das das zufällig ausgewählte Team nicht direkt angezeigt wird, sondern erst nach ein paar Sekunden. Ich klicke auf den Button und dann wird z.B. Team 2 angezeigt, dann Team 6, dann Team 1 usw. Nach einer gewissen (eingestellten) Zeit bleibt dann ein Team in Zelle B6 stehen.
Danach klicke ich wieder auf den Button und das gleiche Spiel beginnt (ohne das bereits in Zelle B6 stehende Team!).
Ich hoffe es ist so verständlicher? :-)
Anzeige
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 15:56:13
Daniel
und was soll das?
unnötiger weise künstlich Spannung erzeugen?
kannst dir ja ne Schleife einbauen, die erst 3-4 mal (je nach gewünschter Anzahl) einen Wert aus D kopiert und in B einfügt, ohne diesen in D zu löschen.
Dafür muss dann aber der Wert in B wieder gelöscht werden, da der nächste ja an gleicher Stelle eingefügt werden soll.
Erst beim finalen Durchgang löscht du dann in D und lässt in B den Wert stehen.
die Wartezeit kannst du mit Application.Wait Now + TimeSerial(0, 0, 5) erzeugen.
im TimeSerial steht der erste Parameter für Stunden, der zweite für Minuten und der dritte für Sekunden.
Gruß Daniel
Anzeige
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 16:22:55
Andreas
ja genau, etwas Spannung tut der Sache gut :-)
Ich bekomme die schleife nicht richtig hin, der Timer ist schon mal sehr gut.
Wenn ich .ClearContents weg mache bleibt die Zelle in Spalte D gefüllt.
Ok aber dann wird die nächste Zelle in Spalte B befüllt.
Kannst du mir ein Beispiel schreiben?
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 16:46:22
Daniel
Hi
und in B muss das Clear-Contents rein, damit beim nächsten mal die selbe Zelle überschrieben wird.
erst beim Finalen Durchlauf tauschst du das dann und führst dann das ClearContents in D aus und lässt es in B weg.
(dh du musst den lezten Durchgang dann nochmal extra nach der Schleife hinschreiben.
Gruß Daniel
Anzeige
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 17:09:26
Andreas
Sorry ich krieg es nicht hin. Hab leider nicht viel Erfahrung mit VBA Skripten.
Ich habe es so versucht:
Sub Zufall()
Dim x As Long, y As Long
Application.Wait Now + TimeSerial(0, 0, 2)
If WorksheetFunction.CountA(Range("D6:D17")) = 0 Then
MsgBox "Keine Werte in Spalte D vorhanden"
Exit Sub
End If
If WorksheetFunction.CountBlank(Range("B6:B17")) = 0 Then
MsgBox "Keine freien Plätze in Spalte B vorhanden"
Exit Sub
End If
With Range("D6:D17").SpecialCells(xlCellTypeConstants, 3)
x = WorksheetFunction.RandBetween(1, .Areas.Count)
y = WorksheetFunction.RandBetween(1, .Areas(x).Cells.Count)
With .Areas(x).Cells(y)
.Copy Range("B6:B17").SpecialCells(xlCellTypeBlanks)(1)
End With
End With
With Range("D6:D17").SpecialCells(xlCellTypeConstants, 3)
x = WorksheetFunction.RandBetween(1, .Areas.Count)
y = WorksheetFunction.RandBetween(1, .Areas(x).Cells.Count)
With .Areas(x).Cells(y)
.Copy Range("B6:B17").SpecialCells(xlCellTypeBlanks)(1)
.ClearContents
End With
End With
End Sub

Anzeige
AW: per Zufall Zelle kopieren (Makro)
10.04.2017 18:13:12
Daniel
Hi
dann probiers mal so: 

Sub Zufall()
Dim x As Long, y As Long
Dim i As Long
Dim rngZiel As Range
Application.Wait Now + TimeSerial(0, 0, 2)
If WorksheetFunction.CountA(Range("D6:D17")) = 0 Then
MsgBox "Keine Werte in Spalte D vorhanden"
Exit Sub
End If
If WorksheetFunction.CountBlank(Range("B6:B17")) = 0 Then
MsgBox "Keine freien Plätze in Spalte B vorhanden"
Exit Sub
End If
'--- Zielzelle speichern
Set rngZiel = Range("B6:B17").SpecialCells(xlCellTypeBlanks)(1)
With Range("D6:D17").SpecialCells(xlCellTypeConstants, 3)
'--- Spannungsschleife
For i = 1 To 4
x = WorksheetFunction.RandBetween(1, .Areas.Count)
y = WorksheetFunction.RandBetween(1, .Areas(x).Cells.Count)
With .Areas(x).Cells(y)
.Copy rngZiel
Application.Wait Now + TimeSerial(0, 0, 1)
rngZiel.ClearContents
End With
Next
'--- finaler lauf
x = WorksheetFunction.RandBetween(1, .Areas.Count)
y = WorksheetFunction.RandBetween(1, .Areas(x).Cells.Count)
With .Areas(x).Cells(y)
.Copy rngZiel
.ClearContents
End With
End With
End Sub
Gruß Daniel
Anzeige
AW: per Zufall Zelle kopieren (Makro)
11.04.2017 17:49:23
snb
Oder
Sub M_snb()
sn = Range("D6:D17")
sq = sn
Range("Z1:Z12") = "=Rand()"
sp = [transpose(rank(Z1:Z12,Z1:Z12))]
Range("Z1:Z11").ClearContents
For j = 1 To UBound(sq)
sq(j, 1) = sn(sp(j), 1)
Next
Range("B6:B17") = sq
End Sub

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige