Zeilen per Zufall auswählen incl Bedingung

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Staedte() Dim Anzahl As Long Dim StartZeile As Long, EndZeile As Long, Zufallszeile As Long Dim AlteZeile As Long, LetzteZeile As Long Dim Zufall As Long Dim LngI As Long, LngX As Long, LngY As Long Dim Vergleich As String Dim Liste(100) As Variant Const Prozent = 2 Randomize 'Alte Einträge löschen aus den Spalten D und E Range(Cells(2, 4), Cells(Rows.Count, 5)).ClearContents 'Städteliste aus Spalte A einlesen For LngI = 2 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(LngI, 1) Cells(LngI - 1, 1) Then LngX = LngX + 1 Liste(LngX) = Cells(LngI, 1) End If Next 'Nach angegebener Prozentzahl Liste zufällig generieren For LngY = 1 To LngX Anzahl = WorksheetFunction.CountIf(Range("A2:A1201"), Liste(LngY)) StartZeile = WorksheetFunction.Match(Liste(LngY), Range("A1:A1201"), 0) EndZeile = StartZeile + Anzahl - 1 Zufall = Anzahl * Prozent / 100 For LngI = 1 To Zufall Zufallszeile = Round(Rnd() * Anzahl, 0) + StartZeile If AlteZeile = Zufallszeile Then LngI = LngI - 1 Else AlteZeile = Zufallszeile LetzteZeile = Cells(Rows.Count, 4).End(xlUp).Row + 1 Cells(LetzteZeile, 4) = Cells(Zufallszeile, 1) Cells(LetzteZeile, 5) = Cells(Zufallszeile, 2) End If Next Next End Sub

Option Explicit Sub Staedte() Dim Anzahl As Long Dim StartZeile As Long, EndZeile As Long, Zufallszeile As Long Dim AlteZeile As Long, LetzteZeile As Long Dim Zufall As Long Dim LngI As Long, LngX As Long, LngY As Long Dim Vergleich As String Dim Liste(100) As Variant Const Prozent = 2 Dim Wks1 As Worksheet, Wks2 As Worksheet Set Wks1 = Worksheets("Tabelle1") ' Anpassen auf die Eingabetabelle Set Wks2 = Worksheets("Tabelle2") ' Anpassen auf die Ausgabetabelle Randomize 'Alte Einträge löschen aus den Spalten A und B aus Tabelle 2 Wks2.Range(Wks2.Cells(2, 1), Wks2.Cells(Rows.Count, 2)).ClearContents 'Städteliste aus Spalte A einlesen aus Tabelle 1 For LngI = 2 To Wks1.Cells(Rows.Count, 1).End(xlUp).Row If Wks1.Cells(LngI, 1) Wks1.Cells(LngI - 1, 1) Then LngX = LngX + 1 Liste(LngX) = Wks1.Cells(LngI, 1) End If Next 'Nach angegebener Prozentzahl Liste zufällig generieren in Tabelle 2 For LngY = 1 To LngX Anzahl = WorksheetFunction.CountIf(Wks1.Range("A2:A1201"), Liste(LngY)) StartZeile = WorksheetFunction.Match(Liste(LngY), Wks1.Range("A1:A1201"), 0) EndZeile = StartZeile + Anzahl - 1 Zufall = WorksheetFunction.RoundUp(Anzahl * Prozent / 100, 0) For LngI = 1 To Zufall Zufallszeile = Round(Rnd() * Anzahl, 0) + StartZeile If AlteZeile = Zufallszeile Then LngI = LngI - 1 Else AlteZeile = Zufallszeile LetzteZeile = Wks2.Cells(Rows.Count, 1).End(xlUp).Row + 1 Wks2.Cells(LetzteZeile, 1) = Wks1.Cells(Zufallszeile, 1) Wks2.Cells(LetzteZeile, 2) = Wks1.Cells(Zufallszeile, 2) End If Next Next End Sub

Hallo Andy,
Es wird eine neue Tabelle erstellt wo die Städte sortiert werden in ein Array eingelesen und per nicht wiederholender Zufallszahl Adressen wiedergegeben.
Hier mein Versuch:
Option Explicit

Sub Staedte3()
Dim Wks1 As Worksheet, Wks2 As Worksheet
Dim LngLetzte As Long, LngCounter As Long
Dim StartZeile As Integer, EndZeile As Integer, LngZeile As Integer, Zeile As Long, Anzahl As  _
Long
Dim ZufallAnzahl As Long
Dim VarArr1() As String, VarArr2() As String
Dim Col1 As New Collection
Dim Wiederholungen() As Long
Const Prozent As Double = 0.02
Set Wks1 = Worksheets("Tabelle1")
Wks1.Copy After:=Wks1
ActiveSheet.Name = "NeueListe " & Worksheets.Count
Set Wks2 = ActiveSheet
Wks2.Range("A1").Sort key1:=Wks2.Range("A1"), order1:=xlAscending, Header:=xlNo
LngLetzte = Wks2.Cells(Rows.Count, 1).End(xlUp).Row
ReDim VarArr1(1 To LngLetzte)
ReDim VarArr2(1 To LngLetzte)
For LngCounter = 1 To LngLetzte
VarArr1(LngCounter) = Wks2.Cells(LngCounter, 1)
VarArr2(LngCounter) = Wks2.Cells(LngCounter, 2)
Next
Wks2.UsedRange.Delete
On Error Resume Next
For LngCounter = 1 To UBound(VarArr1)
Col1.Add VarArr1(LngCounter), CStr(VarArr1(LngCounter))
Next
On Error GoTo 0
For LngCounter = 1 To Col1.Count
Anzahl = UBound(Filter(VarArr1, Col1(LngCounter), True, 1)) + 1
StartZeile = Application.Match(Col1(LngCounter), VarArr1(), 0)
EndZeile = StartZeile + Anzahl - 1
ZufallAnzahl = WorksheetFunction.RoundUp(Anzahl * Prozent, 0)
'*****  Zufallszahlen ohne Wiederholungen von NEPUMUK   *****
Dim i As Integer, fFeld() As Integer, iTemp As Integer, iZ As Integer
ReDim fFeld(1 To Anzahl)
For i = 1 To Anzahl
fFeld(i) = i
Next i
For i = Anzahl To 1 Step -1
Randomize Timer
iZ = Int((i * Rnd) + 1)
iTemp = fFeld(iZ)
fFeld(iZ) = fFeld(i)
fFeld(i) = iTemp
Next i
ReDim Wiederholungen(1 To ZufallAnzahl)
For i = 1 To ZufallAnzahl
Wiederholungen(i) = fFeld(i)
Next i
'*****  Zufallszahlen ohne Wiederholungen von NEPUMUK   *****
For LngZeile = 1 To ZufallAnzahl
Zeile = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(Zeile, 1) = VarArr1(Wiederholungen(LngZeile) + StartZeile - 1)
Cells(Zeile, 2) = VarArr2(Wiederholungen(LngZeile) + StartZeile - 1)
Next
Next
End Sub

Rückmeldung obs Hilft wäre nett.
Gruß aus der Domstadt Köln.

Option Explicit Sub GruppenZufall() ' Liste ist sortiert nach Spalte A Dim lngQ As Long, arQA, arQB, nn As Long, zz As Long Dim stOrt() As String, arBis() As Long, ii As Long, jj As Long Dim anzW As Long, lngZ As Long, zDup() As Long, zuf As Long Dim tt As Long, arErg() Const Proz As Long = 2 ' Auswahl von 2% With Sheets("Tabelle1") ' Quelltabelle lngQ = .Cells(.Rows.Count, 1).End(xlUp).Row arQA = .Cells(1, 1).Resize(lngQ) arQB = .Cells(1, 2).Resize(lngQ) End With ReDim stOrt(1 To lngQ) ReDim arBis(0 To lngQ) nn = 1 stOrt(nn) = arQA(1, 1) For zz = 2 To lngQ If stOrt(nn) arQA(zz, 1) Then arBis(nn) = zz - 1 nn = nn + 1 stOrt(nn) = arQA(zz, 1) lngZ = lngZ + _ Application.RoundUp((arBis(nn - 1) - arBis(nn - 2)) * Proz / 100, 0) End If Next zz arBis(nn) = lngQ lngZ = lngZ + _ Application.RoundUp((arBis(nn) - arBis(nn - 1)) * Proz / 100, 0) ReDim Preserve stOrt(1 To nn) ReDim Preserve arBis(0 To nn) ReDim arErg(1 To lngZ, 1 To 2) zz = 0 Randomize For ii = 1 To nn anzW = arBis(ii) - arBis(ii - 1) - 1 ' Anz. Werte - 1 lngZ = Application.RoundUp(anzW * Proz / 100, 0) ' Anz. Stichprobe ReDim zDup(1 To lngZ) For jj = 1 To lngZ zz = zz + 1 zuf = Int(anzW * Rnd() + arBis(ii - 1)) + 1 Do ' keine Dubletten For tt = 2 To jj - 1 If zuf = zDup(tt - 1) Then Exit For Next tt zuf = Int(anzW * Rnd() + arBis(ii - 1)) + 1 Loop Until tt >= jj arErg(zz, 1) = stOrt(ii) ' Ergebnis in Array arErg(zz, 2) = arQB(zuf, 1) Next jj Next ii Worksheets.Add Before:=Sheets(1) ' Ausgabe in neuer Zieltabelle Cells(1, 1).Resize(UBound(arErg), 2) = arErg End Sub

Hi Andy,
"ich hatte am Code nichts geändert, habe jetzt Deine Vorlage benutzt und siehe da alles funktioniert"
Das erscheint mir nun aber sehr merkwürdig.
Ein Code, der in verschiedenen Mappen verschiedene Ergebnisse produziert?
Wie kannst du da sicher sein, dass in der nächsten Mappe nicht noch ein anderes Ergebnis erscheint?
Mich würde schon interessieren, wie der Fehler
"Dein Script ist schon sehr nah an der Lösung dran, jedoch rundet es nicht richtig.
Wenn 65 Adressen vorhanden sind erscheinen 3 Ergebnisse, richtig wäre 2
Wenn 108 Adressen vorhanden sind erscheinen 4 Ergebnisse, richtig wäre 3"
entstand.
Wenn du den Fehler selbst nicht aufdeckst, wäre ich dir dankbar für das Hochladen einer Mappe, in der der Fehler auftritt.
Wie schrieb ich so schön: "Das Rätsel sollte sich lösen lassen..."
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich und: Schönes Wochenende!

Beliebteste Forumthreads (12 Monate)

Zeilen per Zufall auswählen incl Bedingung

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread