Excel 2003 - VB-Script "Zufall" - Zufallsgenerator

Liebe VB-Profis,
für die Auswahl von Teillisten habe ich irgendwann mal das beiliegende VB-Script "Zufall" bekommen. Leider funktioniert es nicht mehr korrekt und der Ersteller des Script ist nicht mehr verfügbar.
Das Script steigt mit der Fehlermeldung "Laufzeitfehler '-2147417848 (80010108)': Die Methode 'Cells' für das Objekt '_Worksheet' ist fehlgeschlagen" aus.
Wenn ich über "Debuggen" in das Script einsteige, bleibt es bei ".Cells(i + zo, s + so) = Tabelle1.Cells(G(i), s)" hängen.
Nach Beendigung des Debuggers wird nur eine unvollständige Ausgabe erzeugt.
Was ist an der Methode ".Cells...." nicht mehr korrekt? Benötige hierfür einmal Eure Unterstützung, damit das Script wieder fehlerfrei durchläuft
Momentan sind im Script jeweils 250 Einträge als Teilliste aus der Gesamtliste von 1265 Einträgen (Tabelle1) hinterlegt.
Die ausgewählte Teilliste wird auf einem separaten Tabellen-Blatt (Datum Uhrzeit) abgelegt. Hat auch schon mal funktioniert
Wäre es möglich, wenn das Script gestartet wird, die Anzahl der auszuwählenden Datensätze in einer Eingabe-Box an das Script zu übergeben, damit man diese Änderung nicht im Script vornehmen muss?
Vielen Dank für Eure Hilfe und
GlG Pia Bird
In der beiliegenden Excel-Datei sind Beispieldatensätze und das VB-Script:
https://www.herber.de/bbs/user/109013.zip
Hier nun das Script:

Sub Zufall()
Dim G(250) As Integer
Dim vorhanden As Boolean
Dim a, i, s, z, x, q, wd As String
Dim so  'Spaltenoffset
Dim zo  'Zeilenoffset
Dim NewSheet As Sheets, nsNr
Dim Kopf(11) As String
Dim Anfang, Ende, Blatt As String
'Nachfrage, ob gezogen werden soll...
q = MsgBox("Soll eine neue Auswahl durchgeführt werden?", _
vbYesNo, "Neue Ziehung - " & Date)
If q  vbYes Then Exit Sub
'  Hier die Parameter einstellen, die relevant sind
Kopf(1) = "Anzahl"
Kopf(2) = "AuswahlNr"  'Spalte A
Kopf(3) = "Titel1"     'Spalte B
Kopf(4) = "Anrede"     'Spalte C
Kopf(5) = "Name"       'Spalte D
Kopf(6) = "Name2"      'Spalte E
Kopf(7) = "Geschlecht" 'Spalte F
Kopf(8) = "Plz"        'Spalte G
Kopf(9) = "Ort"        'Spalte H
Kopf(10) = "Strasse"   'Spalte I
Kopf(11) = "Haus_Nr"   'Spalte J
Blatt = "Tabelle1"     'In diesem Blatt stehen die Namen drin
a = 250                 'Anzahl der zu ziehenden Namen
Anfang = 2             'Beginn der Einträge festlegen (Zeile)
'Das Ende der Einträge automatisch ermitteln
Ende = Sheets(Blatt).Range("A65536").End(xlUp).Row
'Alternativ kann das Ende auch explizit angegeben werden
'Ende = 3000
'Plausibilitätsprüfung
If Ende - Anfang

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub ZufallNeu() Dim G() As Long Dim vorhanden As Boolean Dim a&, i&, z&, x& ' & = as long Dim q Dim zo& 'Zeilenoffset Dim nsNr As Long Dim Kopf(1 To 1, 1 To 11) As String Dim Anfang As Long, Ende As Long Dim Blatt As Worksheet 'Nachfrage, ob gezogen werden soll... q = MsgBox("Soll eine neue Auswahl durchgeführt werden?", _ vbYesNo, "Neue Ziehung - " & Date) If q vbYes Then Exit Sub ' Hier die Parameter einstellen, die relevant sind Kopf(1, 1) = "Anzahl" Kopf(1, 2) = "AuswahlNr" 'Spalte A Kopf(1, 3) = "Titel1" 'Spalte B Kopf(1, 4) = "Anrede" 'Spalte C Kopf(1, 5) = "Name" 'Spalte D Kopf(1, 6) = "Name2" 'Spalte E Kopf(1, 7) = "Geschlecht" 'Spalte F Kopf(1, 8) = "Plz" 'Spalte G Kopf(1, 9) = "Ort" 'Spalte H Kopf(1, 10) = "Strasse" 'Spalte I Kopf(1, 11) = "Haus_Nr" 'Spalte J Set Blatt = Sheets("Tabelle1") 'In diesem Blatt stehen die Namen drin a = 250 'Anzahl der zu ziehenden Namen ReDim G(1 To a, 1 To 1) 'damit ist G genauso groß wie a Anfang = 2 'Beginn der Einträge festlegen (Zeile) 'Das Ende der Einträge automatisch ermitteln Ende = Blatt.Range("A" & Rows.Count).End(xlUp).Row ' rows.count ist die letzte Zeile, unabhängig von der Excel-Version 'Plausibilitätsprüfung If Ende - Anfang

Function Zufallszahlen(von&, bis&, anzahl&, Optional typ As Long = 1) ' "Standardfunktion" für Ziehung ohne Doppelte ' Wertebereich von..bis: *************** ' von: kleinerer Wert ' bis: größerer Wert ' anzahl: Anzahl der zu ziehenden Zahlen ' optionale Typangabe: ***************** ' 0: eindimensionales Array ' sonst: zweidimensionales Array hoch Dim aIn, aOut Dim i&, k& ' hier ist Raum für Plausibilitätsprüfungen: ' a) ist von vbYes Then Exit Sub Set Blatt = Sheets("Tabelle1") 'In diesem Blatt stehen die Namen drin a = 250 'Anzahl der zu ziehenden Namen Anfang = 2 'Beginn der Einträge festlegen (Zeile) Ende = Blatt.Range("A" & Rows.Count).End(xlUp).Row ' rows.count ist die letzte Zeile, unabhängig von der Excel-Version 'Plausibilitätsprüfung If Ende - Anfang

Sub Zufall() Dim a, q Dim Kopf As String Dim Anfang, Ende, Blatt As String 'Nachfrage, ob gezogen werden soll... q = MsgBox("Soll eine neue Auswahl durchgeführt werden?", _ vbYesNo, "Neue Ziehung - " & Date) If q <> vbYes Then Exit Sub '-------------------------------------------------------------- ' Hier die Parameter einstellen, die relevant sind '-------------------------------------------------------------- Kopf = "Anzahl,AuswahlNr,Titel1,Anrede,Name,Name2,Geschlecht," _ & "Plz,Ort,Strasse,Haus_Nr" Blatt = "Tabelle1" 'In diesem Blatt stehen die Namen drin a = 250 'Anzahl der zu ziehenden Namen Anfang = 2 'Beginn der Einträge festlegen (Zeile) 'Das Ende der Einträge automatisch ermitteln Ende = Sheets(Blatt).Range("A65536").End(xlUp).Row 'Plausibilitätsprüfung If Ende - Anfang < a Then MsgBox "Es sollen mehr Namen gezogen werden, " & vbCrLf & _ " als zur Verfügung stehen." Exit Sub End If 'Neues Tabellenblatt anlegen und mit Datum + Zeit benennen Sheets.Add(After:=Sheets(Sheets.Count)).Name = _ Format(Now, "DD.MM.YYYY hh-mm-ss") With ActiveSheet .Cells(1, 1).Resize(, 11) = Split(Kopf, ",") .Cells(2, 1).Resize(a).FormulaR1C1 = "=RAND()^2" With .Cells(2, 2).Resize(a) .FormulaR1C1 = "=INDIRECT(""" & Blatt & "!A""&RANK(RC[-1],C[-1])+1)" .Value = .Value End With .Cells(2, 1).Resize(a).FormulaR1C1 = "= ""'"" & TEXT(ROW(R[-1]C),""@"")" .Cells(2, 3).Resize(a, 9).FormulaR1C1 = _ "=IF(VLOOKUP(RC2," & Blatt & "!C1:C10,COLUMN(RC[-1]),0)<>0,VLOOKUP(RC2," _ & Blatt & "!C1:C10,COLUMN(RC[-1]),0),"""")" With .Cells(2, 1).Resize(a, 11) .Value = .Value End With End With End Sub

Option Explicit Sub Zufall() Dim a, Kopf As String Dim Anfang, Ende, Blatt As String '-------------------------------------------------------------- ' Hier die Parameter einstellen, die relevant sind '-------------------------------------------------------------- Kopf = "Anzahl,AuswahlNr,Titel1,Anrede,Name,Name2,Geschlecht," _ & "Plz,Ort,Strasse,Haus_Nr" Blatt = "Tabelle1" 'In diesem Blatt stehen die Namen drin a = InputBox("Anzahl der zu ziehenden Namen" & vbLf & vbLf & "0= abbrechen", , 250) If a = 0 Or a = "" Then Exit Sub Anfang = 2 'Beginn der Einträge festlegen (Zeile) 'Das Ende der Einträge automatisch ermitteln Ende = Sheets(Blatt).Range("A65536").End(xlUp).Row 'Plausibilitätsprüfung If Ende - Anfang < a Then MsgBox "Es sollen mehr Namen gezogen werden, " & vbCrLf & _ " als zur Verfügung stehen." Exit Sub End If 'Neues Tabellenblatt anlegen und mit Datum + Zeit benennen Sheets.Add(After:=Sheets(Sheets.Count)).Name = _ Format(Now, "DD.MM.YYYY hh-mm-ss") With ActiveSheet .Cells(1, 1).Resize(, 11) = Split(Kopf, ",") .Cells(2, 1).Resize(Ende).FormulaR1C1 = "=RAND()^2" With .Cells(2, 2).Resize(a) .FormulaR1C1 = "=INDIRECT(""" & Blatt & "!A""&RANK(RC[-1],C[-1])+1)" .Value = .Value End With .Cells(2, 1).Resize(Ende).FormulaR1C1 = _ "= IF(RC[1]<>"""",""'"" & TEXT(ROW(R[-1]C),""@""),"""")" .Cells(2, 3).Resize(a, 9).FormulaR1C1 = _ "=IF(VLOOKUP(RC2," & Blatt & "!C1:C10,COLUMN(RC[-1]),0)<>0,VLOOKUP(RC2," _ & Blatt & "!C1:C10,COLUMN(RC[-1]),0),"""")" With .Cells(2, 1).Resize(Ende, 11) .Value = .Value End With End With End Sub

Liebe VB-Experten,
ganz herzlichen Dank für die vielen Rückmeldung/Vorschläge. Leider war ich ein wenig indisponiert, deswegen melde ich mich auch jetzt erst. Bitte um Verständnis ... Danke.
Alle Vorschläge mit einer festen Vorgabeanzahl im Code laufen super schnell und fehlerfrei durch.
Der Vorschlag von UweD berücksichtigt aber auch die Abfrage nach der gewünschten Anzahl der zu ziehenden Namen. Würde ich gerne so sofort übernehmen und benutzen, wenn UweD noch einen kleinen Fehler beheben könnte (ist für Euch wahrscheinlich eine Kleinigkeit).
Hier nun die Problembeschreibung
Wenn ich in der Eingabe-Box eine Anzahl der zu ziehenden Namen eingebe, beispielsweise 5, 10 oder 100 und die Abfrage starte, erhalte ich immer die Meldung "Es sollen mehr Namen gezogen werden, als zur Verfügung stehen.", danach steigt das Programm dann ohne etwas zu machen aus.
Wäre sehr lieb, wenn Du das noch beheben könntest.
Besten Dank an alle und ganz liebe Grüße
Pia Bird

Beliebteste Forumthreads (12 Monate)

Excel 2003 - VB-Script "Zufall" - Zufallsgenerator

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Excel 2003 - VB-Script "Zufall" - Zufallsgenerator

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

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread