Excel代码问题，非常感谢！

gwjkkkkk

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ar, br, i&, j&
    If Target.Address <> "$B$23" Then Exit Sub
    If Not IsNumeric(Target.Value) Then Exit Sub
   
    If Target.Value >= 1 And Target.Value <= 252 Then
         ReDim ar(1 To 10)
         For i = 1 To UBound(ar)
             ar(i) = i - 1
         Next i
         ar = combinArr1(ar, 5)
        
         Application.EnableEvents = False
         [H26].Resize(5) = Application.Transpose(ar(Target.Value))
         Application.EnableEvents = True
    End If
End Sub

Function combinArr1(ByVal ar, ByVal n&)
    Dim br&(), cr, vResult, i&, j&, m&, iCount&, iGroup&, vTemp
   
    m = UBound(ar)
    iGroup = Application.Combin(m, n)
    ReDim vResult(1 To iGroup)
    ReDim br&(1 To n)
    ReDim cr(1 To n)
    If n = 1 Then
        For i = 1 To iGroup
            cr(1) = ar(i)
            vResult(i) = cr
        Next i
        combinArr1 = vResult
        Exit Function
    End If
    For j = 1 To n - 1: br(j) = j: Next
    iCount = 0
   
    Do
        For i = br(n - 1) + 1 To m
            br(n) = i
            iCount = iCount + 1
            For j = 1 To n
                cr(j) = ar(br(j))
            Next j
            vResult(iCount) = cr
        Next
        If br(n - 1) < br(n) - 1 Then
            br(n - 1) = br(n - 1) + 1
        Else
            For j = n - 2 To 1 Step -1
                If br(j) <> br(j + 1) - 1 Then
                    vTemp = br(j) + 1: br(j) = vTemp: j = j + 1
                    Do Until j = n
                        br(j) = br(j - 1) + 1: j = j + 1
                    Loop
                    Exit For
                End If
            Next
        End If
    Loop Until iCount = iGroup
    combinArr1 = vResult
End Function

gwjkkkkk

LSYYLW 发表于 2024-8-24 22:26
非常感谢老师，K列里的数字是我用来给老师演示依次显示结果数字的顺序用的，实际应用时没有这一列数字。

请参考。。。

cidanji

LSYYLW

ztsss161511 发表于 2024-8-24 22:28
偶也是新人，试一下错了别笑话：

Sub xunhuan()

非常感谢老师！

LSYYLW

醉眼看尘世 发表于 2024-8-24 22:56
以下代码放在工作表事件程序窗格中

非常感谢老师，代码非常好用。

LSYYLW

gwjkkkkk 发表于 2024-8-25 09:37
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ar, br, i&, j&
    If Target.Address   ...

非常感谢老师，代码非常好用。鲜花明天为您献上。

LSYYLW

cidanji 发表于 2024-8-25 10:18

非常感谢老师，代码非常好用。