这段代码运行时提示过程太大，请问如何精简？

阿智

由于代码重复过多，导致无法运行，本人水平有限，望各位高人帮忙修改一下。谢谢。
该代码功能是在规定范围内随机抽取98个单元格的值并输出到M列里，随机抽取到的98个单元格不能重复。

liulang0808

建议楼主结合附件，举例描述下自己的需求。。。。

阿智

liulang0808 发表于 2020-3-12 19:47
建议楼主结合附件，举例描述下自己的需求。。。。

谢谢你的回复。我已经把代码要实现的功能说明加上。

liulang0808

Set rn1 = Rng1.Cells(x1).Offset(0, 0).Resize(1, 1) ' 1
改成Set rn1 = Rng1.Cells(x1)，其他雷同
Set rngAll = Union(rn1, Rng1.Cells(x1)) ' 这个地方楼主看下要不要改
代码看了部分，或许使用字典或者数组之类也能处理吧
或者说楼主换个思路看看是否可行

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    For Each Rng In [a1].CurrentRegion
        d(Rng.Address) = Rng.Value
    Next Rng
    str1 = ""
    For j = 0 To d.Count - 1
        x = WorksheetFunction.RandBetween(0, d.Count - 1)
        str1 = str1 & "," & d.items()(x)
        d.Remove d.keys()(x)
    Next j
    If [m1] = "" Then
        [m1] = Mid(str1, 2)
    Else
        Cells(Rows.Count, "m").End(3).Offset(1) = Mid(str1, 2)
    End If
End Sub

liulang0808

不知道理解的对不对，供参考

阿智

liulang0808 发表于 2020-3-12 20:27
不知道理解的对不对，供参考

谢谢回复。这个代码确实精简了，只是得不到原来那种结果。原来的代码是逐个产生随机单元格，遇到相同的单元格后会重新再随机一次，随着选中的单元格越多，重新随机的可能性就会越多。最终得到的随机数跟一次性产生得到的随机数有比较大的区别。比如原来的代码产生的随机数50000条里会有一条中含有连续20个1，精简后的代码产生的随机数却没出现过这中现象。能用原来代码的思路做精简吗？再次感谢。

lkqsmxw

Sub suiji()
    Dim STR1, M, X, N, Rng, rn
    STR1 = ""
    M = 98
    [a1:j10].Interior.ColorIndex = xlNone
    Set Rng = [a1:j10]
CF:
    For N = M To 0 Step -1
    X = WorksheetFunction.RandBetween(1, Rng.Cells.Count)
    Set rn = Rng.Cells(X).Offset(0, 0).Resize(1, 1)
    If rn.Interior.ColorIndex <> 4 Then
    rn.Interior.ColorIndex = 4
    'Rng.Cells(x).Interior.ColorIndex = 3
    If STR1 = "" Then STR1 = rn Else STR1 = STR1 & "," & rn
    M = M - 1
    End If
    Next N
    If M <> 0 Then GoTo CF
Cells(Rows.Count, "m").End(3).Offset(1) = STR1
[a1:j10].Interior.ColorIndex = xlNone
End Sub

lkqsmxw

我认为这样就可达到你的要求

阿智

lkqsmxw 发表于 2020-3-13 10:14
我认为这样就可达到你的要求

谢谢回复。这个代码跟源代码思路确实一样。发现个小问题，在对它进行连续100次测试时，它会一直处于未响应状态，等了半个多钟都这样。