☰

パーセンテージ値をランダム化するにはどうすればいいですか?

tag-icon • tag-icon microsoft-excel vba
パーセンテージ値をランダム化するにはどうすればいいですか?

VBA Excel に問題があります。

列Fには57.07%という数字があります。この列には102行あります。パーセンテージでランダムな値を生成するのが目的ですが、これらのランダムな数字の合計平均は57.07%でなければなりません。

ランダムな完全な数字を生成することができました。しかし、何らかの理由で小数点を追加したり削除したりすると、結果が得られません。

Sub RandomiseSum()
    Dim countries As Range, country As Range, pageviews As Range, clicks As Range, impressions As Range, col_f As Range, col_g As Range, col_h As Range, earnings As Range



Dim arr() As Double, i, z, y As Integer

'~~>Count the result of the range of countries
Set countries = Range("B4:B102")
Set pageviews = Range("C4:C102")
Set impressions = Range("D4:D102")
Set clicks = Range("E4:E102")
Set col_f = Range("F4:F102")
Set col_g = Range("G4:G102")
Set col_h = Range("H4:H102")
Set earnings = Range("I4:I102")
ReDim arr(countries.count - 1)
For i = 0 To countries.count - 1
    arr(i) = Rnd
Next i
i = i - 1                                           '~~> Remove 1 from the total cell number in order to put the decimals/diferences in it at the end

'~~> Totals
TotalC = Range("C2").Value
TotalD = Range("D2").Value
TotalE = Range("E2").Value
avg_f = Range("F2").Value
avg_g = Range("G2").Value
avg_h = Range("H2").Value
TotalI = Range("I2").Value


col_h = avg_h
half1 = i / 2
half2 = (i / 2) + 1
z = half2
y = 4
x = 0

Do Until x = half1
    this_nr = "H" & y
    xnum = WorksheetFunction.RandBetween(0, 42) / 100
    Range(this_nr).Value = Range(this_nr).Value - xnum
     
    y = y + 1
    z_nr = "H" & z
    Range(z_nr).Value = Range(z_nr).Value + xnum
    
    z = z + 1
    x = x + 1
Loop
rnr = 0
Do Until rnr = half1
    x12 = WorksheetFunction.RandBetween(4, 102)
    x22 = WorksheetFunction.RandBetween(4, 102)
    x12 = "H" & x12
    x22 = "H" & x22
    x3 = x12
    
    Range(x12).Value = Range(x22).Value
    Range(x22).Value = Range(x3).Value

    rnr = rnr + 1
    Loop
        y = 4
        z = half2
        For x = 0 To x = half1
            this_nr = "H" & y
            z_nr = "H" & z
      
           Range(this_nr).Value = Range(this_nr).Value - 0.3
           Range(z_nr).Value = Range(z_nr).Value + 0.03
            
            z = z + 1
            x = x + 1
         Next x
End Sub

画像からわかるように、すべてのセルに .07 が表示されますが、一部のセルからその値を削除して他のセルに追加することはできません。

画像:

何かアイデアはありますか?
私のループは間違っていますか?

答え1

なんとか解決できました。他にも同じ問題に遭遇した人がいたら、ここにコードがあります。ここで私がやったことは、「xnum2」という別の変数を追加して、ランダムな小数点を生成し、ループごとにその値を CELLx.value から削除して別の CELLy.value に追加することで、平均が同じになるようにしたことです。

    col_h = avg_h
    half1 = i / 2
    half2 = (i / 2) + 1
    z = half2
    y = 4
    x = 0
    
    Do Until x = half1
        this_nr = "H" & y
        xnum = WorksheetFunction.RandBetween(0, 42) / 100
        Range(this_nr).Value = Range(this_nr).Value - xnum
        
      xnum2 = WorksheetFunction.RandBetween(0, 9) / 10000
   Range(this_nr).Value = Range(this_nr).Value - xnum2
        
        y = y + 1
        z_nr = "H" & z
        Range(z_nr).Value = Range(z_nr).Value + xnum
      Range(z_nr).Value = Range(z_nr).Value + xnum2
        
        z = z + 1
        x = x + 1
    Loop
    rnr = 0
    Do Until rnr = half1
        x12 = WorksheetFunction.RandBetween(4, 102)
        x22 = WorksheetFunction.RandBetween(4, 102)
        x12 = "H" & x12
        x22 = "H" & x22
        x3 = x12
        
        Range(x12).Value = Range(x22).Value
        Range(x22).Value = Range(x3).Value
    
        rnr = rnr + 1
        Loop

関連情報