EXCEL - Makro für Stichprobenziehung

Question

Hallo Leute,

zur angehängten Beispieldatei hätte ich ein paar Fragen wie man mein Problem mit hilfe eines Makros lösen könnte.

Ich habe eine Tabelle in der ein Fahrplan zu einer Buslinie enthalten ist. (Tabellenblatt: Linie 40)
Außerdem habe ich noch eine Tabelle, anhand deren Daten ich Stichproben aus dem Fahrplan ziehen möchte. (Tabellenblatt: BASIS)

Der Fahrplan ist nach Zeitzonen eingeteilt die einer bestimmten Zahl zugeordnet sind (Spalte B) und einer Richtung in die der Bus fährt (Spalte A).

Bei dem Tabellenblatt "BASIS" stehen diese Zeitzonen in Zeile 3 und die Fahrtrichtung in Spalte B.
Die roten Zahlen zeigen die Anzahl an zufälligen Stichproben aus der jeweiligen Zeitzone an.

WAS DAS MAKRO KÖNNEN SOLL:

- Wenn im TB-BASIS in Spalte A z.B. "Linie 40" steht, dann suche das TB-Linie 40

dann

- Wenn im TB-BASIS in Spalte B "Richtung 1" steht, dann suche im gefundenen TB in Spalte A nach "Richtung 1"

dann

- Wenn im TB-BASIS in Zeile 3 eine der "Zeitzonen-Zahlen" steht, dann suche im gefundenen TB in Spalte B nach der Zahl.

dann

- die ROTEN Zahlen im TB-Basis sollen dann angeben wieviele Stichproben aus dem gefundenen Zeitraum gezogen werden sollen. (steht da eine 1, dann eine, steht da ne 2 dann 2 usw.)

Dann sollen die "zufällig" gewählten Zeilen alle untereinander in das TB-Stichproben ab Zeile 9 Kopiert werden.


PUUUHH, viel viel Text, aber ich hoffe das es mit der Beispieldatei in Kombination einigermaßen verständlich ist wie ich es meine ;)

Beispieldatei:

http://www.file-upload.net/download-8561363/Beispiel---Stichprobenziehung---Kopie.xlsx.html


DANKE SCHONMAL,

Gruß in die Runde vom Lefty

Answer 1

Hallo,

leider für mich auch mit dem Beispiel nicht verständlich was du da genau machen willst.

Gruß

Helmut

Answer 2

Hallo Lefty,

schau mal ob das Makro deinen Bedürfnissen entspricht:

Sub stichprobe()

Dim wksLinie, Richtung As String
Dim azproben, i, zeile, lzbasis, lsbasis, lzlinie, tz, z, zaehler As Long
Dim ArrZeilen()
Dim Bereich As Range
Dim Zelle As Variant
Dim wksExists As Boolean

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'letzte Spalte im Arbeitsblatt Basis feststellen
lsbasis = Sheets("Basis").UsedRange.SpecialCells(xlCellTypeLastCell).Column

'im Arbeitsblatt Linie die letzte Zeile mit einer Linie ermitteln
For zeile = Sheets("Basis").UsedRange.SpecialCells(xlCellTypeLastCell).Row To 5 Step -1
If Left(Sheets("Basis").Cells(zeile, 1), 5) = Linie Then
lzbasis = zeile
Exit For
End If
Next zeile

'Bereich mit Anzahl Proben durchsuchen
Set Bereich = Range(Sheets("Basis").Cells(5, 3), Sheets("Basis").Cells(lzbasis, lsbasis))

For Each Zelle In Bereich
'Falls Zellinhalt größer 0 Stichprobennahme starten
If Zelle.Value > 0 And Left(Sheets("Basis").Cells(Zelle.Row, 1), 5) = "Linie" Then
azproben = Zelle.Value 'Anzahl Stichproben in Variable schreiben
wksLinie = Sheets("Basis").Cells(Zelle.Row, 1) 'Name der Linie = Name des Arbeitsblattes zur Probenentnahme
zaehler = 0 'Zähler zurücksetzen

'Prüfen, ob Arbeitsblatt mit entsprechenden Namen vorhanden ist
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name = wksLinie Then
wksExists = True
Exit For
Else
wksExists = False
End If
Next i

If wksExists = True Then

Richtung = Sheets("Basis").Cells(Zelle.Row, 2)
tz = Sheets("Basis").Cells(3, Zelle.Column)
lzlinie = Sheets(wksLinie).UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Array für Datensätze dimensionieren
ReDim ArrZeilen(lzlinie)

'Prüfen, wieviel Datensätze die Bedingungen erfüllen
For zeile = 1 To lzlinie
If Sheets(wksLinie).Cells(zeile, 1) = Richtung And Sheets(wksLinie).Cells(zeile, 2) = tz Then
zaehler = zaehler + 1
ArrZeilen(zaehler) = zeile 'Zeilennummer wird in Array geschrieben
End If
Next zeile
'Array mit Zeilennummern wird auf tatsächliche Größe dimensioniert
ReDim Preserve ArrZeilen(zaehler)

'Stichproben raussuchen
For z = 1 To azproben
'Zufallszahlen generieren
Randomize
zeile = ArrZeilen(Int((UBound(ArrZeilen) - 1 + 1) * Rnd + 1))
'kopieren
Sheets(wksLinie).Rows(zeile).Copy
With Sheets("Stichprobe").Cells(Sheets("Stichprobe").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, 1)
.PasteSpecial Paste:=xlPasteValues 'nur Inhalte einfügen
.Columns("C").NumberFormat = "hh:mm" 'Spalte C wird im Zeitformat formatiert
.Columns("E").NumberFormat = "hh:mm" 'Spalte D wird im Zeitformat formatiert
End With
Next z

Else

'hier schreiben, dass Arbeitsblatt nicht existiert
With Sheets("Stichprobe")
.Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, 1) = "Ein Blatt mit dem Namen " & wksLinie & " existiert nicht!"
End With

End If

End If

Next Zelle

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 3

Hallo M.O.,

danke für die Antwort.

Habe das Makro in ein neues Modul kopiert und wenn ich es starte, dann gibt Excel bzw. VBA folgende Fehlermeldung:

- Laufzeitfehler 9: Index außerhalb des gültigen Bereichs

und wenn ich auf Debuggen klicke, dann markiert es folgende Zeile gelb:

zeile = ArrZeilen(Int((UBound(ArrZeilen) - 1 + 1) * Rnd + 1))


Was mach ich falsch???

Gruß Lefty

Answer 4

PS: in der Beispieldatei läuft das Makro habe ich grad festgestellt.

Answer 5

Hallo Lefty,

warum das Makro in deiner Orginaldatei nicht läuft, kann ich so natürlich nicht sagen.

Ich habe in das Makro nun noch eine Fehlerbehandlung eingebaut. Probiere mal das folgende Makro:

Sub stichprobe()

Dim wksLinie, Richtung As String
Dim azproben, i, zeile, lzbasis, lsbasis, lzlinie, tz, z, zaehler As Long
Dim ArrZeilen()
Dim Bereich As Range
Dim Zelle As Variant
Dim wksExists As Boolean

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'letzte Spalte im Arbeitsblatt Basis feststellen
lsbasis = Sheets("Basis").UsedRange.SpecialCells(xlCellTypeLastCell).Column

'im Arbeitsblatt Linie die letzte Zeile mit einer Linie ermitteln
For zeile = Sheets("Basis").UsedRange.SpecialCells(xlCellTypeLastCell).Row To 5 Step -1
If Left(Sheets("Basis").Cells(zeile, 1), 5) = Linie Then
lzbasis = zeile
Exit For
End If
Next zeile

'Bereich mit Anzahl Proben durchsuchen
Set Bereich = Range(Sheets("Basis").Cells(5, 3), Sheets("Basis").Cells(lzbasis, lsbasis))

For Each Zelle In Bereich
'Falls Zellinhalt größer 0 Stichprobennahme starten
If Zelle.Value > 0 And Left(Sheets("Basis").Cells(Zelle.Row, 1), 5) = "Linie" Then
azproben = Zelle.Value 'Anzahl Stichproben in Variable schreiben
wksLinie = Sheets("Basis").Cells(Zelle.Row, 1) 'Name der Linie = Name des Arbeitsblattes zur Probenentnahme
zaehler = 0 'Zähler zurücksetzen

'Prüfen, ob Arbeitsblatt mit entsprechenden Namen vorhanden ist
For i = 1 To ThisWorkbook.Sheets.Count
If Sheets(i).Name = wksLinie Then
wksExists = True
Exit For
Else
wksExists = False
End If
Next i

If wksExists = True Then

Richtung = Sheets("Basis").Cells(Zelle.Row, 2)
tz = Sheets("Basis").Cells(3, Zelle.Column)
lzlinie = Sheets(wksLinie).UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Array für Datensätze dimensionieren
ReDim ArrZeilen(lzlinie)

'Prüfen, wieviel Datensätze die Bedingungen erfüllen
For zeile = 1 To lzlinie
If Sheets(wksLinie).Cells(zeile, 1) = Richtung And Sheets(wksLinie).Cells(zeile, 2) = tz Then
zaehler = zaehler + 1
ArrZeilen(zaehler) = zeile 'Zeilennummer wird in Array geschrieben
End If
Next zeile
'Array mit Zeilennummern wird auf tatsächliche Größe dimensioniert
ReDim Preserve ArrZeilen(zaehler)
'Prüfen, ob überhaupt Zeilen gefunden wurden, die die Bedinungen erfüllen
If UBound(ArrZeilen) > 0 Then

'Stichproben raussuchen
For z = 1 To azproben
'Zufallszahlen generieren
Randomize
zeile = ArrZeilen(Int((UBound(ArrZeilen)) * Rnd + 1))
'kopieren
Sheets(wksLinie).Rows(zeile).Copy
With Sheets("Stichprobe").Cells(Sheets("Stichprobe").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, 1)
.PasteSpecial Paste:=xlPasteValues 'nur Inhalte einfügen
.Columns("C").NumberFormat = "hh:mm" 'Spalte C wird im Zeitformat formatiert
.Columns("E").NumberFormat = "hh:mm" 'Spalte D wird im Zeitformat formatiert
End With
Next z

Else

'hier schreiben, dass keine Übereinstimmung gefunden wurde
With Sheets("Stichprobe")
.Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, 1) = wksLinie & " - " & Richtung & ": keine Übereinstimmung gefunden"
End With
End If

Else

'hier schreiben, dass Arbeitsblatt nicht existiert
With Sheets("Stichprobe")
.Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, 1) = "Ein Blatt mit dem Namen " & wksLinie & " existiert nicht!"
End With

End If

End If

Next Zelle

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 6

JA JA JA,

wie das halt manchmal so ist mit dem Wald und den Bäumen.....

Es lag an der Beschriftung der Register, da hatte sich bei mir ein Bock eingeschlichen.

Bei deinen beiden Makros lief jetzt auf dem ersten Blick alles richtig.

Tausend DANK dafür!

Gruß Lefty