在vba中随机播放数组

问题描述 投票:1回答:2

我需要无重复地对数组中的值进行混洗,我需要在代码中添加些什么来避免重复

Function Resample(data_vector)


   n = UBound(data_vector)
   ReDim shuffled_vector(n)
   For i = 1 To n
      shuffled_vector(i) = data_vector(WorksheetFunction.RandBetween(1, n))
   Next i
End Function
arrays excel vba shuffle
2个回答
4
投票

这将使数组随机化:

Function Resample(data_vector() As Variant) As Variant()
    Dim shuffled_vector() As Variant
    shuffled_vector = data_vector
    Dim i As Long
    For i = UBound(shuffled_vector) To LBound(shuffled_vector) Step -1
        Dim t As Variant
        t = shuffled_vector(i)
        Dim j As Long
        j = Application.RandBetween(LBound(shuffled_vector), UBound(shuffled_vector))
        shuffled_vector(i) = shuffled_vector(j)
        shuffled_vector(j) = t
    Next i
    Resample = shuffled_vector
End Function

您可以这样打电话:

Sub try()
    Dim x() As Variant
    x = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 0)

    x = Resample(x)

    MsgBox Join(x, ",")
End Sub

enter image description here


0
投票

新数组应该具有相同的维数吗?试试这个:

Function Resample(data_vector)
   dim upper_bound as Long
   dim lower_bound as Long
   dim dict as Object
   dim i as Long
   dim lRandomNumber As Long
   Set dict = CreateObject("Scripting.Dictionary")

   upper_bound = UBound(data_vector)
   lower_bound  = LBound(data_vector)
   ReDim shuffled_vector(upper_bound)

   For i = 1 To upper_bound
      lRandomNumber = WorksheetFunction.RandBetween(1, upper_bound)
      If not dict.Exists(Cstr(lRandomNumber)) Then
           shuffled_vector(i) = data_vector(lRandomNumber)
           dict.Add Key:=Cstr(lRandomNumber), Item:=True
      Else
           lRandomNumber = GetNotUsedNumber(dict, lower_bound, upper_bound)
           shuffled_vector(i) = data_vector(lRandomNumber)
           dict.Add Key:=Cstr(lRandomNumber), Item:=True
      End If
   Next i
End Function


Pivate Function GetNotUsedNumber(byref dict as long, byref lower_bound as long, byref upper_bound as long)

dim i as Long
For i = lower_bound to upper_bound 
if not dict.exists(Cstr(i)) then
    iResult = i
    Exit For
end if
end function
© www.soinside.com 2019 - 2024. All rights reserved.