Makro dass zufällige Texte ausgibt

Hallo an euch alle,
ich wäre froh wenn ihr mir helft. Ich frage nach einem Makro, da eine Formel nicht zwischen Farben unterscheiden kann.
Ich habe eine Spalte A (A2:A9087) mit 9086 Texten (und einer Überschrift), dabei steht jeweils eine Zahl in Spalte D.
Das Makro soll generell nur Texte mit schwarzer Schriftfarbe ausgeben:
1. 10 zufällige Texte, bei denen eine 0 dabei steht,
2. 10 zufällige Texte, bei denen eine Zahl zwischen 1 und 30 steht
3. 10 zufällige Texte, bei denen eine Zahl größer 30 steht.
4. diese 30 Texte in Tabelle1!A1:A30 schreiben
5. die Schriftfarbe der gewählten Texte ändern (Farbe egal, solang nicht weiß), sodass sie nicht erneut ausgeben werden wenn ich das Makro erneut ausführe.
Sollten keine 10 Texte mit einer 0 vorhanden sein, sollen entsprechend mehr Texte mit Zahlen zwischen 1 und 30 genommen werden, sollten nicht genügend Texte mit Zahlen zwischen 1 und 30 da sein sollen entsprechend mehr Texte mit Zahlen größer 30 genommen werden, sodass auf jeden Fall 30 Texte ausgewählt werden.
Ist das umsetzbar?
Danke schonmal für die Hilfe
Jenny

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Keine Beispieldatei hochgeladen.
Ist das eine Art Vokabeltrainer?
Musste selbst was erstellen. Probier es bitte aus.
Erst diesen Code in ein allgemeines Modul kopieren:

Sub Vorbereitung()
Dim lZeile As Long
With Tabelle1
.Columns(1).Clear
.Columns(4).Clear
End With
With Tabelle2
.Columns(1).Clear
.Columns(4).Clear
.Cells(1, 1) = "Überschrift"
For lZeile = 2 To 10000      'Anpassen
.Cells(lZeile, 1).Value = "Wort Nr" & lZeile
.Cells(lZeile, 1).Font.ColorIndex = xlAutomatic
.Cells(lZeile, 4).Value = Int(Rnd * 50)
Next lZeile
End With
End Sub
Sub Jenny()
Textsammlung 0, 0
Textsammlung 1, 30
Textsammlung 31, 999
End Sub
Private Function Textsammlung(iMinimum As Integer, iMaximum As Integer) As Variant
Dim aSammlung()     As Long
Dim lZeile          As Long
Dim lFund           As Long
Dim iPicker         As Integer
Dim iLetzteZeile    As Integer
Dim i               As Long
ReDim aSammlung(0)
With Tabelle2
'Sammlung erstellen
For lZeile = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Cells(lZeile, 4).Value >= iMinimum And .Cells(lZeile, 4).Value  3 Then
ReDim Preserve aSammlung(UBound(aSammlung) + 1)
aSammlung(UBound(aSammlung)) = lZeile
End If
End If
Next lZeile
'Zufällige Texte übertragen
If UBound(aSammlung) > 0 Then
'Funde zufällig rauspicken
For lFund = 1 To 10
iPicker = Int(Rnd * UBound(aSammlung) + 1)
iLetzteZeile = Tabelle1.Cells(Rows.Count, 1).End(xlUp).Row + 1
Tabelle1.Cells(iLetzteZeile, 1).Value = .Cells(aSammlung(iPicker), 1).Value
Tabelle1.Cells(iLetzteZeile, 4).Value = .Cells(aSammlung(iPicker), 4).Value
.Cells(aSammlung(iPicker), 1).Font.ColorIndex = 3
If UBound(aSammlung) = 1 Then Exit For
For i = iPicker To UBound(aSammlung) - 1
aSammlung(i) = aSammlung(i + 1)
Next i
ReDim Preserve aSammlung(UBound(aSammlung) - 1)
Next lFund
End If
End With
End Function

Dann Vorbereitung ausführen:
Es werden im Blatt "Tabelle2" 10.000 Texten und Zahlen zwischen 0 und 49 erstellt.
Dann Jenny ausführen:
Im Blatt "Tabelle2" werden 10 zufällige nicht rote Zeilen mit "0" ausgesucht, der Text rot gefärbt und in "Tabelle1" übertragen. Falls weniger als 10 Nullen vorhanden sind, dann eben diese.
Dann dasselbe für 1 bis 30 und nochmals für 31 bis 999.
Ergebnis: In Tabelle1 steht eine Liste mit max. 30 Zeilen.
Automatische Ergänzung auf 30 habe ich nicht eingebaut.
Jenny kann beliebig wiederholt werden. Dabei werden die roten Texte immer mehr und die schwarzen immer weniger.
Konnte ich helfen?
LGB

Beliebteste Forumthreads (12 Monate)

Makro dass zufällige Texte ausgibt

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread