麻烦各位前辈帮忙看看怎么随机选取工作簿2的内容填充到工作簿1

宠你丫头

应用题库在工作簿2，怎么随机抽取5题填充到工作簿1，不能重复？？

一把小刀闯天下

Option Explicit

Const NUM As Long = 5

Sub test()
  Dim arr, i, n, t
  arr = Sheets("sheet2").[a1].CurrentRegion.Offset(, 1).Resize(, 1)
  If NUM > UBound(arr, 1) Then MsgBox "!": Exit Sub
  For i = 1 To NUM
    n = Int(Rnd * (UBound(arr, 1) - i + 1)) + i
    t = arr(i, 1): arr(i, 1) = arr(n, 1): arr(n, 1) = t
  Next
  Sheets("sheet1").[a11].Resize(NUM) = arr
End Sub

宠你丫头

一把小刀闯天下 发表于 2020-1-13 14:25
Option Explicit

Const NUM As Long = 5

好像有点问题，合并单元格之后只出了3道应用题

excel海

你看看怎么样
Sub 随机抽题()
    Dim i, arr
    ReDim arr(1 To 5)
    N = Sheet2.Cells(Rows.Count, 1).End(3).Row
    k = 1: j = ""
    Do While k <= 5
        sn = Application.WorksheetFunction.RandBetween(1, N)
        If InStr(j, sn) = 0 Or k = 1 Then
            arr(k) = Sheet2.Cells(sn, 2)
            k = k + 1
            j = j & sn
        Else
        End If
    Loop
    k = 0
    For i = 11 To 19 Step 2
        k = k + 1
        Sheet1.Cells(i, 1) = arr(k)
    Next
End Sub

宠你丫头

一把小刀闯天下 发表于 2020-1-13 14:25
Option Explicit

Const NUM As Long = 5

Dim dict
    Set dict = CreateObject("Scripting.Dictionary")
    i = 1
    Do While i < 10
        s = Application.WorksheetFunction.RandBetween(1, 220)
        If dict.exists(s) = False Then
            Sheet1.Cells(10 + i, 1) = Sheet2.Cells(s, 2)
            i = i + 1
        End If

一把小刀闯天下

宠你丫头 发表于 2020-1-13 14:57
好像有点问题，合并单元格之后只出了3道应用题

'就是要空一行是吧，，，

Option Explicit

Const NUM As Long = 5

Sub test()
  Dim arr, i, n, t
  arr = Sheets("sheet2").[a1].CurrentRegion.Offset(, 1).Resize(, 1)
  If NUM > UBound(arr, 1) Then MsgBox "!": Exit Sub
  ReDim brr(1 To NUM * 2, 1 To 1) As String
  For i = 1 To NUM
    n = Int(Rnd * (UBound(arr, 1) - i + 1)) + i
    t = arr(i, 1): brr(2 * i - 1, 1) = arr(n, 1): arr(n, 1) = t
  Next
  Sheets("sheet1").[a11].Resize(2 * NUM) = brr
End Sub

宠你丫头

谢谢你们了