So, nun habe ich auch noch die benötigte ...
20.07.2013 15:40:47
Luc:-?
…Subroutine geschrieben, Tess;
da du aber bisher keine Infos zur Organisation des Ganzen geliefert hast, musst du das jetzt so akzeptieren wie es ist und ggf selbst anpassen…
Rem Bildet Mittelwerte gleichteilg Ziehgg aus Gesamtbereich ohne Wdholgg;
' wtTeil=Anz gleichgroßer Teile, adQBer=Gesamt(zell)bereich - änderbar!
' Achtung! Benötigt udFkt RandAr!
' Vs1.1 -Luc -cd:20130720 -1pub:20130720herber.de -lupd:20130720t
Sub ZufallsMw_glTeil()
Const wtTeil As Integer = 3, adQBer$ = "A2:A73"
Dim anzWt As Long, ix As Long, iz As Long, az As Long, _
oGrz() As Long, uGrz() As Long, erg() As Double, _
isMoRows As Boolean, dzTrZ$, mxTrZ As String, _
arQD, arZZ, zwErg(), zz As Variant, _
QBer As Range, ZBer As Range, aSh As Worksheet, aWd As Window
On Error GoTo fx
dzTrZ = Application.International(xlDecimalSeparator)
Set aSh = ActiveSheet: Set aWd = ActiveWindow
Set QBer = aSh.Range(adQBer): Set ZBer = aWd.RangeSelection
If ZBer.Rows.Count = 1 Then
If ZBer.Columns.Count wtTeil Then Err.Raise xlErrRef
ElseIf ZBer.Rows.Count wtTeil Then
Err.Raise xlErrRef
ElseIf ZBer.Columns.Count > 1 Then
Err.Raise xlErrRef
End If
ReDim oGrz(wtTeil), uGrz(wtTeil), erg(1 To wtTeil)
anzWt = QBer.Count: arZZ = RandAr(anzWt)
Let isMoRows = QBer.Rows.Count > 1: mxTrZ = Array(",", ";")(Abs(isMoRows))
If isMoRows Then ReDim zwErg(anzWt - 1, 0) Else ReDim zwErg(anzWt - 1)
With WorksheetFunction
arQD = .Transpose(.Transpose(QBer)): az = LBound(arQD)
For ix = 1 To wtTeil
oGrz(ix) = ix * anzWt \ wtTeil: uGrz(ix) = 1 + oGrz(ix - 1)
For iz = 0 To anzWt - 1
If isMoRows Then
zwErg(iz, 0) = .Match(.Small(arZZ, iz + 1), arZZ, 0)
zwErg(iz, 0) = IIf(zwErg(iz, 0) >= uGrz(ix) And _
zwErg(iz, 0) = uGrz(ix) And _
zwErg(iz)
Falls es dich oder anderweitig interessiert — habe auch noch eine neue Version der UDF RandAr geschrieben, der zusätzlich ein Multiplikationsfaktor und eine maxDezimalStellenAnzahl übergeben wdn kann.
Gruß Luc :-?