在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