在Excel中生成隨機單詞列表，但沒有重複

Question

我試圖生成中的單詞B從列中的給定單詞列A。

現在我在Excel VBA代碼做到這一點：

Function GetText() 
    Dim GivenWords 
    GivenWords = Sheets(1).Range(Sheets(1).[a1], Sheets(1).[a20]) 
    GetText = A(Application.RandBetween(1, UBound(A)), 1) 
End Function 

這會產生從我在A1:A20提供的列表中的詞，但我不希望任何重複。

GetText()將運行15次在列B從B1:B15。

如何檢查B列中的任何重複項，或者更有效地在列表中使用後，從列表中刪除單詞？

例如，

1. 選擇範圍A1:A20
2. 選擇一個值隨機（例如A5）
3. A5是在列B1
4. 選擇範圍A1:A4 and A6:A20
5. 選擇一個值隨機（例如A7）
6. A7是在列B2
7. 重複等

Answer 1

這比我想象的要複雜。該公式應該用作垂直數組，例如。選擇希望輸出的單元格，按f2 type = gettext（A1：A20）並按ctrl + shift +輸入

這意味着您可以選擇輸入單詞在工作表中的位置，並且輸出可以是直到輸入的列表，在這一點上，你將開始得到＃N/A錯誤。

Function GetText(GivenWords as range) 
    Dim item As Variant 
    Dim list As New Collection 
    Dim Aoutput() As Variant 
    Dim tempIndex As Integer 
    Dim x As Integer 

    ReDim Aoutput(GivenWords.Count - 1) As Variant 
    For Each item In GivenWords 
     list.Add (item.Value) 
    Next 
    For x = 0 To GivenWords.Count - 1 
     tempIndex = Int(Rnd() * list.Count + 1) 
     Aoutput(x) = list(tempIndex) 
     list.Remove tempIndex 
    Next 

    GetText = Application.WorksheetFunction.Transpose(Aoutput()) 
End Function 

Answer 2

下面是代碼。我在使用它後刪除單元格。請在使用前備份您的數據，因爲它會刪除單元格內容（它不會自動保存...但以防萬一）。你需要運行'main'sub來獲得輸出。

Sub main() 
    Dim i As Integer 
    'as you have put 15 in your question, i am using 15 here. Change it as per your need. 
    For i = 15 To 1 Step -1 
    'putting the value of the function in column b (upwards) 
    Sheets(1).Cells(i, 2).Value = GetText(i) 
    Next 
End Sub 

Function GetText(noofrows As Integer) 
    'if noofrows is 1, the rand function wont work 
    If noofrows > 1 Then 
    Dim GivenWords 
    Dim rowused As Integer 
    GivenWords = Sheets(1).Range(Sheets(1).Range("A1"), Sheets(1).Range("A" & noofrows)) 

    'getting the randbetween value to a variable bcause after taking the value, we can delete the cell. 
    rowused = (Application.RandBetween(1, UBound(GivenWords))) 
    GetText = Sheets(1).Range("A" & rowused) 

    Application.DisplayAlerts = False 
    'deleting the cell as we have used it and the function should not use it again 
    Sheets(1).Cells(rowused, 1).Delete (xlUp) 
    Application.DisplayAlerts = True 
    Else 
    'if noofrows is 1, there is only one value left. so we just use it. 
    GetText = Sheets(1).Range("A1").Value 
    Sheets(1).Cells(1, 1).Delete (xlUp) 
    End If 
End Function 

希望這會有所幫助。

Answer 3

這是我會怎麼做，用2個額外的列，並沒有VBA代碼...

 
A    B  C     D 
List of words Rand  Rank     15 Words 
Apple   =RAND() =RANK(B2,$B$2:$B$21) =INDEX($A$2:$A$21,MATCH(ROW()-1,$C$2:$C$21,0)) 

副本B2和C2下來儘可能的列表，並拖動d下來然而，你想要很多的話。

複製單詞列表中的某個地方，因爲你每次換一次牀單上的東西（或重新計算）時，你會得到的話

的新列表使用VBA：

Sub GetWords() 
Dim Words 
Dim Used(20) As Boolean 
Dim NumChosen As Integer 
Dim RandWord As Integer 

Words = [A1:A20] 

NumChosen = 0 

While NumChosen < 15 
    RandWord = Int(Rnd * 20) + 1 
    If Not Used(RandWord) Then 
     NumChosen = NumChosen + 1 
     Used(RandWord) = True 
     Cells(NumChosen, 2) = Words(RandWord, 1) 
    End If 
Wend 
End Sub