Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender Navigationstipps
Inhaltsverzeichnis

Excel 2003 - VB-Script "Zufall" - Zufallsgenerator

Excel 2003 - VB-Script "Zufall" - Zufallsgenerator
25.10.2016 15:11:07
PIO
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 

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

Betreff
Datum
Anwender
Anzeige
Excel 2003 - VB-Script "Zufall" - Zufallsgenerator
25.10.2016 15:56:12
Michael
Hi Pia Bird,
das Skript kann zwar hie und da optimiert werden, aber bei mir läuft es fehlerfrei durch.
Der einzige "echte" Fehler, der mir auf den ersten Blick auffällt, ist die Position des randomize: das sollte in einem Skript nur einmal ausgeführt werden, d.h. vor die For-Schleife gesetzt werden (also 3 Zeilen nach oben).
Ich bastle mal kurz daran und melde mich wieder.
Schöne Grüße,
Michael
AW: Excel 2003 - VB-Script "Zufall" - Zufallsgenerator
25.10.2016 16:38:09
Michael
Hi,
versuch's mal damit:
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 
Schöne Grüße,
Michael
Anzeige
funktioniert es? Hier noch ein Update...
25.10.2016 18:06:45
Michael
Hi,
der Code ist jetzt (für mich zufriedenstellend) optimiert:
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 
Schöne Grüße,
Michael
Anzeige
AW: Excel 2003 - VB-Script "Zufall" - Zufallsgenerator
25.10.2016 19:03:37
UweD
Hallo
habe einiges verkürzt,
die Schleifen rausgenommen
und durch Formeln getauscht
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

LG UweD
Anzeige
AW: noch eine Änderung
25.10.2016 19:27:41
UweD
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


Anzeige
haste das getestet?
25.10.2016 20:05:47
Michael
Hi Uwe,
das ist ja noch ne völlig andere Variante, die ich gleich mal getestet habe.
Bei 250 bricht das Ding aber trotzdem ab, weil es nicht 250, sondern "250" ist, also bitte: a*1
Schöne Grüße,
Michael
ich schon
25.10.2016 20:20:19
Michael
Hi Uwe,
falls Du so weit einsteigen willst noch die komplette Datei mit allen Makros anbei.
Ich habe interessehalber eine Zeitmessung in unsere beiden "finalen" Codes eingebaut:
https://www.herber.de/bbs/user/109016.zip
Schöne Grüße,
Michael
AW: ich schon
26.10.2016 08:34:37
UweD
Ja, haperte immer noch ein wenig.
Interessant

Ursprungsmakro ~218
Mein Code       ~78
Deiner          ~15

Hoffen wir mal, dass sich Pia mal meldet.
Anzeige
jetzt hapert es an Pia
26.10.2016 13:20:56
Michael
Hi Uwe,
ich wollte die Zeiten nicht posten, weil ich währenddessen beim Überprüfen des Uploads auf einen seltsamen Effekt gestoßen bin: die Zeiten bei der Entwicklung stimmten mit den von Dir genannten überein (wir haben anscheinend zufällig ähnlich schnelle CPUs), während sie bei der Ausführung aus der ZIP (ohne Wegspeichern) langsamer waren.
Du hast auch keinen Fehler im Originalcode festgestellt?
Naja, mal sehen, was Pia sagt (wenn sie was sagt).
Schöne Grüße,
Michael
AW: noch eine Änderung
27.10.2016 14:48:20
PIO
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
Anzeige
AW: noch eine Änderung
27.10.2016 15:04:59
UweD
Hallo
hier fehlte die Umwandlung von einer Textzahl in eine Zahl
    If Ende - Anfang CDbl(a) Then
dann müsste es gehen
LG UweD
AW: noch eine Änderung
27.10.2016 16:42:45
PIO
Hallo UweD,
perfekt!!! läuft jetzt super schnell und fehlerfrei!!!
Vielen Dank und
GlG
Pia Bird
AW: gern geschehen owt
27.10.2016 17:08:04
UweD

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige