AW: Stichprobenziehung mit VBA
30.01.2007 23:10:58
ingUR
Hallo, Marcus,
die Zusatzinformationen und Deine Erläuterungen haben da schon ein paar Vereinfachungen ermöglicht, die ich zuvor so nicht erkannte.
Ein Grundgerüst für eine VBA-Prozedur kann vielleicht folgender Modul-Programmcode verwendet werden:
Option Explicit
Const NSP As Long = 10 'Anzahl det Stichprobenelemente
Const PTYP As Integer = 1 'Leittyp / Primättyp
Const DATASHEET = "Tabelle1"
Const DATARANGE = "B2:F6"
Sub stichprobenN()
Dim ws As Worksheet
Dim Typ, AllData, refTyp, NTyp() As Long, nSel() As Integer
Dim maxt As Integer, t As Integer
Dim maxRec As Long, iRec As Long
Dim maxItem As Long, iItem As Long
Dim s As Integer, p As Integer
Dim TypP As Integer, maxSProben As Long, iProbe As Long, SProbe
Typ = Array("", "A1", "B1", "B2", "C1", "C2")
'Lese Tabelle
Set ws = Worksheets(DATASHEET)
AllData = ws.Range(DATARANGE).Value
maxt = UBound(Typ)
maxRec = UBound(AllData, 1)
maxItem = UBound(AllData, 2)
ReDim NTyp(maxRec, maxItem), sumNTyp(maxItem), nSel(maxRec)
'ermittle Anzahl des Vorkommens eines jeden Typs
For iRec = 1 To maxRec
'ermittle Häufigkeit der Typen in einem Datensatz
For iItem = 1 To maxItem
refTyp = AllData(iRec, iItem)
For t = 1 To maxItem
If refTyp = Typ(t) Then
NTyp(iRec, t) = NTyp(iRec, t) + 1 'Symmenbildung je Datensatz
sumNTyp(t) = sumNTyp(t) + 1 'Summenbildung je Typ
Exit For
End If
Next t
Next iItem
Next iRec
TypP = PTYP 'Primärtyp-Index
maxSProben = NSP
'Setze Stichprobenumfang und zulässige Anzahl einer jeden Teilmenge
' TypP:=50%, TypX:=50%/(maxt-1) auf nächst Ganzzahl aufgerundet
For t = 1 To maxt
If t = TypP Then
sumNTyp(t) = Int(maxSProben / 2)
Else
sumNTyp(t) = Int((maxSProben / 2) / (maxt - 1)) + 1
End If
Next t
' 'alternativ, wenn nur mindestens ein Element eines
' 'zweiten Sekundärtyps im Stichprobenumfang ausreicht
' 'neben bereits einem ausgewähltem Sekundärtyp
' For t = 1 To maxt
' If t = TypP Then
' sumNTyp(t) = maxSProben / 2
' Else
' sumNTyp(t) = maxSProben / 2 - 1
' End If
' Next t
ReDim SProbe(maxRec, 3)
Randomize
'Zufallsziehungen von maxSProben/2-Elementen des Primärtyps
s = 0
While iProbe < maxSProben / 2
iRec = Int(maxRec * Rnd()) + 1
'sind aus dem Datensatz noch keine drei Elemente gewählt?
If nSel(iRec) < 3 Then
'enthält Datensatz (noch) ein Element vom Typ t
If NTyp(iRec, TypP) > 0 Then
iProbe = iProbe + 1
nSel(iRec) = nSel(iRec) + 1
'füge Element der Stichprobe zu
SProbe(iRec, nSel(iRec)) = Typ(TypP)
NTyp(iRec, TypP) = NTyp(iRec, TypP) - 1
End If
End If
Wend
'Zufallsziehungen von maxSProben/2-Elementen aus der Menge der Sekundärtypen
iProbe = 0
While iProbe < maxSProben / 2
iRec = Int(maxRec * Rnd()) + 1
'sind aus dem Datensatz noch keine drei Elemente gewählt?
If nSel(iRec) < 3 Then
'wähle einen Sekundärtyp
t = TypP
While t = TypP Or t > maxt
t = Int(maxt * Rnd()) + 1
Wend
'enthält Datensatz (noch) ein Element vom Typ t und
'sind noch nicht die maximal mögliche Anzahl der Elemente
'vom Typ t gezogen
If NTyp(iRec, t) > 0 And sumNTyp(t) > 0 Then
iProbe = iProbe + 1
nSel(iRec) = nSel(iRec) + 1
'füge Element der Stichprobe zu
SProbe(iRec, nSel(iRec)) = Typ(t)
NTyp(iRec, t) = NTyp(iRec, t) - 1
sumNTyp(t) = sumNTyp(t) - 1
End If
End If
Wend
For iRec = 1 To maxRec
p = 0
For t = 1 To 3
ws.Cells(iRec + 1, 8 + t) = ""
If SProbe(iRec, t) > 0 Then
p = p + 1
ws.Cells(iRec + 1, maxt + 2 + p) = SProbe(iRec, p)
End If
Next t
Next iRec
Set ws = Nothing
End Sub
In welchem Anwendungsbereich benötigt man eine derart geziehlte Stichprobenauswahl, Marcus?
Gruß,
Uwe