MS-Office-Forum
Google
   

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads Der Renner, 11 Entwicklertools für Access, Tipps & Trick und offene Datenbanken zum einzigartigen Preis.
Themen-Optionen Ansicht
Alt 17.10.2017, 17:01   #1
prome
Neuer Benutzer
Neuer Benutzer
Standard VBA - Stichproben erstellen

Guten Tag,
Ich möchte über VBA eine Stichprobenliste erstellen, die aus mehrere Stichproben pro Ort besteht. Ich hoffe das mir jemand hier helfen kann.
Die Datei besteht aus zwei Tabellenblätter: Stichprobendatei und Parameter.
In Tabelle Stichproben ist in Spalte A eine Nummer und in Spalte B habe ich ein Ort. Die Datensätze sind nach Ort sortiert.
In Tabellenblatt 2 (Parameter) habe ich die Anzahl der Stichproben pro Stadt festgelegt.
Siehe auch Anlage.

Ich möchte das in Spalte E:F (in der Tabelle Stichprobendatei) mir zufällig Stichproben gezogen werden, anhand der Parameter.
Das wären 9 Datensätze aus Berlin, 1 Datensatz aus Düsseldorf usw.
Bei "0" soll kein Datensatz gezogen werden.
Sollte ein Ort neu sein (nicht in Tabelle Parameter vorhanden) dann soll der Ort dort hinzugefügt werden. In diesem Beispiel Wien.

Die Originaldatei hat 3000 - 10000 Datensätze.
Excel Version 2010.

Vielen Dank vorab.
Angehängte Dateien
Dateityp: xlsx Stichproben.xlsx (14,2 KB, 2x aufgerufen)
prome ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 17.10.2017, 17:24   #2
Hajo_Zi
MOF Guru
MOF Guru
Standard

das geht nicht, da eine XLSX Datei kein Makro enthalten kann.
Ich sehe keinen Grund eine Datei 2x zu speichern. Ich führe keine Liste unter welchem Dateinamen ich die Datei gespeichert habe.

GrußformelHomepage

__________________

Signatur in jedem Beitrag
In diesem Forum, kann der Beitrag als gelöst gekennzeichnet werde (unten Links). Bitte macht dies. Damit es auch in der Forumsübersicht gekennzeichnet ist.
Bitte Version angeben. Bei keiner Angabe gehe ich von meinen Angaben aus.
Betriebssystem: Windows 10 - 64 Bit, Office 2016 - 32 Bit.
Hajo_Zi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 17.10.2017, 17:49   #3
Fennek11
MOF User
MOF User
Standard

Hallo,

recht einfach umzusetzen ist der Ansatz der "n-ten Auswahl":

Man sortiert den Datensatz nach dem entscheidenden Kriterium (PLZ) und nimmt dann jede n-te Zeile. N ist Sticheprobe/Datensatz.

Es geht auch mit "=rnd()" bzw "=zufallszahl()"

mfg
Fennek11 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 17.10.2017, 17:51   #4
prome
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Hallo Hajo,

danke für die schnelle Antwort.
Bin noch recht unerfahren, was Hilfe-Foren betrifft.
Ich habe die Datei jetzt als *.xlsm gespeichert und hochgeladen.

Viele Grüße

prome
Angehängte Dateien
Dateityp: xlsm Stichproben.xlsm (14,0 KB, 4x aufgerufen)
prome ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 18.10.2017, 10:01   #5
prome
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Hallo Fennek,
Danke für deine Antwort.
da für viele Orte eine andere Gewichtung vorliegt, geht das mit der n-ten Zeile nicht.

Mit einem klick auf einer Schaltfläche möchte ich die Erstellung der Stichproben generieren (alles über VBA steuern).

Mit Hilfe von Googel (und sehr vielen Stunden) bin ich recht weit gekommen. Aktuell weiß ich nicht weiter.
Für den ersten Ort führt es die Stichprobenauswahl korrekt durch.
Ab dem zweiten Ort hab ich ein Problem bei Zeile:
Code:

arNeu(i) = ar(lngZufall)            ' Diesen Wert umkopieren

Ich stell den vollständigen Code rein.
Code:

Sub Stichproben_erstellen()
Dim ar() As Long, arNeu() As Long, lngZeileAnfang, lngZeileAnzahl As Long
Dim lngSize, i, j, n, lngLetzte, lngLetzteP, lngZufall As Long
Dim intColumns, k, l, m, x As Long
Dim Parameter, Stichproben As Object

Set Stichproben = Workbooks("Stichproben2.xlsm").Sheets("Stichprobendatei")
Set Parameter = Workbooks("Stichproben2.xlsm").Sheets("Parameter")

Worksheets("Stichprobendatei").Activate
lngLetzte = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
lngLetzteP = Sheets("Parameter").Cells(Rows.Count, 1).End(xlUp).Row
lngZeileAnfang = 1
lngZeileAnzahl = 1
l = 1
For k = 1 To lngLetzte                                  'K = Gesamtanzahl Datensätze
    If Range("B1").Offset(k, 0) = Range("B1").Offset(k + 1, 0) Then
        lngZeileAnzahl = lngZeileAnzahl + 1             'Zählt Anzahl Datensätze pro Ort
    Else
        For l = 1 To lngLetzteP                         'L = Anzahl Orte
            If Parameter.Range("A1").Offset(l, 0) = Range("B1").Offset(k, 0) Then
                Parameter.Range("C1").Offset(l, 0) = lngZeileAnzahl 'hinterlegt die Anzahl der Datensätze pro Parameter

'_______________Hier beginnt die eigentliche Stichprobe_____________________________
                lngSize = k                             'Ende Bereich für Stichprobe
                n = Parameter.Range("F1").Offset(l, 0)  'Anzahl der Zufallsziehungen
                
                If n < 1 Then                           'prüft ob für den Ort Stichproben gezogen werden
                    MsgBox "Für diesen Ort gibt es keine Stichproben."
                    lngZeileAnfang = lngSize + 1
                    lngZeileAnzahl = 1
                    Exit For
                End If
        
                ReDim arNeu(1 To n)                     ' Array mit den gezogenen Zeilennummern
                intColumns = 2                          ' die höchste vorkommende Spaltennummer
                ReDim ar(lngZeileAnfang To lngSize)     ' Array mit den vorhandenen Zeilennummern füllen
                For i = lngZeileAnfang To lngSize
                    ar(i) = i
                Next
                
                Randomize Time                          ' Mischen
                For i = 1 To n
                    lngZufall = Int(lngZeileAnzahl * Rnd) + 1   ' Eine zufällige Zahl zwischen 1 ... langSize
'hier hab ich das Problem beim zweiten Durchlauf.
                    arNeu(i) = ar(lngZufall)            ' Diesen Wert umkopieren
                    ar(lngZufall) = ar(k)               ' Diesen Wert durch das letzte Array-Element ersetzen
                    lngZeileAnzahl = lngZeileAnzahl - 1 ' max. Zufallszahl erniedrigen
                Next
                With ActiveSheet                        ' .Cells() ist später in ActiveSheet, Cells() im neuen Blatt
           
                For i = 1 To n                          'x = Zeile bei Treffer Stichproben
                    Cells(i + x, 6).Resize(, intColumns).Value = .Cells(arNeu(i), 1).Resize(, intColumns).Value
                Next
                x = x + n
                End With
                lngZeileAnfang = k + 1
             
'_________________________________________________________________________________________
                lngZeileAnzahl = 1
                Exit For
            End If
        Next
        
    End If
 
Next


End Sub
Da ich auf Arbeit bin, kann ich die aktuelle Datei nicht hochladen.
Hoffe das ein Link auch OK ist.
Stichproben2.xlsm
Dort ist noch ein kleiner Fehler:
Code:

n = Parameter.Range("B1").Offset(l, 0)
ist richtig, statt ("F1")

Ich würde mich sehr freuen wenn mit diesen erweiterten Angaben mir geholfen werden kann.

Viele Grüße
Prome

Geändert von prome (18.10.2017 um 11:19 Uhr).
prome ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 18.10.2017, 12:44   #6
Fennek11
MOF User
MOF User
Standard

Hallo,

teste bitte diesen (erster Versuch) Code:

PHP-Code:

Sub iFen()
Dim Ra As Range
Dim FenR 
As Range
Dim WSF 
As WorksheetFunctionSet WSF Application.WorksheetFunction
Ct 
Sheets(2).Cells(1).CurrentRegion
With Sheets
(1).Cells(1).CurrentRegion
    With 
.Columns(1).Offset(, 2)
        .
Clear
        
.Formula "=rand()"
        
.Value = .Value
    End With
For 2 To UBound(Ct)
    .
AutoFilter 2Ct(c1)
    
Set Ra = .Columns(1).SpecialCells(12).Offset(, 2)
    For 
Each r In Ra
        
If r.Row 1 Then
            Debug
.Print r.Addressr.ValueRa.AddressCt(c1)
            
Rang WSF.Rank_Eq(rRa)
            If 
Rang <= Ct(c2Then r.Offset(, 1) = Rang
        End 
If
    
Next r
    
.AutoFilter
Next c
End With
End Sub 
Bei meinem Test sah es nicht schlecht aus, aber es können noch Fehler drin sein.

mfg
Fennek11 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 18.10.2017, 13:06   #7
Fennek11
MOF User
MOF User
Standard

Hallo,

mit Nachfrage bei Experten klappte auch dieser Code:

PHP-Code:

Sub iFen()
Dim Ra As Range
Dim FenR 
As Range
Dim WSF 
As WorksheetFunctionSet WSF Application.WorksheetFunction
Ct 
Sheets(2).Cells(1).CurrentRegion
With Sheets
(1).Cells(1).CurrentRegion
     
.Columns(1).Offset(, 2).Clear
For 2 To UBound(Ct)
    .
AutoFilter 2Ct(c1)
    
Set Ra = .Columns(1).SpecialCells(12).Offset(, 2)
    
Call Rang(Ra)
    For 
Each r In Ra
        
If r.Value Ct(c2Then Range(r.Address).Clear
    Next r
    
.AutoFilter
Next c
End With
End Sub

Sub Rang
(rng As Range)
If 
rng.Areas.Count 1 Then Set rng rng.Areas(2)
rng.Formula "=rand()"
rng.Value Evaluate("index(rank(" rng.Address ", " rng.Address "), )")
End Sub 
mfg
Fennek11 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 18.10.2017, 14:19   #8
prome
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Hallo Fennek,

sie sind mein Retter.

Nachdem ich
Code:

Dim Ct, r As Variant
Dim c As Long
erfasst habe und hinter dem Next das "c" gelöscht habe hat es mit dem letzten Code geklappt.

Der Rest ist einfach, kriege ich hin.

Vielen Dank.

Viele Grüße
prome

Geändert von prome (18.10.2017 um 14:33 Uhr).
prome ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 00:04 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.

Copyright ©2000-2010 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günther Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.
Beachten Sie bitte auch unsere Nutzungsbedingungen.