Stichprobe nehmen, zugehörigen Wert auslesen
29.10.2015 18:56:30
Bonduca
in meinem Quellblatt "A" Spalte F stehen Werte und in Spalte G zugehörige Namen.
Ich habe hier einen Code, der mir aus den Zahlen im Quellblatt "A" Spalte F eine Stichprobe im Umfang von n in das Zielblatt "B" ab der Zelle D27 schreibt.
Das funktioniert wunderbar.
Könnte man den Code so umfunktionieren, dass die zugehörigen Namen in Spalte G ebenfalls ausgelesen werden und in das Zielblatt eingetragen werden?
Am Schluss sollen also in D:E die Stichprobwerte mit den zugehörigen Namen stehen, die aus dem Quellblatt "A" F:G geholt wurden.
Sub StichProbe()
Dim Quelle As String
Dim Ziel As String
Dim ar As Variant
Dim Zielzellen As Variant
Dim n As Integer
'Dim arNeu As Variant, lngSize As Long, i As Long, lngZufall As Long
Quelle = "A"
Ziel = "B"
Sheets(Quelle).Activate
ar = Range("F4", Range("F4").End(xlDown))
n = 30 'Anzahl Zufallsziehungen bestimmen
Zielzellen = "D27"
Call StichProbe(Quelle, Ziel, ar, n, Zielzellen)
End Sub
Sub StichProbe(Quelle, Ziel, ar, n, Zielzellen)
Dim lngSize As Long
Dim lngZufall As Long
Dim arNeu As Variant
Dim i As Long
Worksheets(Ziel).Activate
' Werte in Array lesen
lngSize = UBound(ar) ' Anzahl der Werte bestimmen
ReDim arNeu(1 To 550, 1 To 1)
Randomize Time
For i = 1 To n
If lngSize = 0 Then
lngSize = UBound(ar)
End If
lngZufall = Int(lngSize * Rnd) + 1 ' Eine zufällige Zahl zwischen 1 ... lngSize
arNeu(i, 1) = ar(lngZufall, 1) ' Diesen Wert umkopieren
ar(lngZufall, 1) = ar(lngSize, 1) ' Diesen Wert durch das letzte Array-Element _
ersetzen
lngSize = lngSize - 1 ' max. Zufallszahl reduzieren
Next
'Worksheets(Ziel).Range("A1").Resize(n).Value = arNeu ' umkopieren
Sheets(Ziel).Range(Zielzellen).Resize(n).Value = arNeu
End Sub
Danke!