[已解决]请老师加一下代码，当前面数比后面数大时不排列组合

sanpiao

请老师加一下代码，当前面数比后面数大时不排列组合

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-7-31 23:04

加紅色部份而已

Dim sj, a(33), b(), d, k&, m&, n&
'隅砱菰寥剒猁腔鼠蚚曹講ㄩ
' 湔溫馱釬桶杅擂郖腔媼峎杅郪sj
' 暮翹杅趼岆瘁笭葩腔杅郪a
' 湔溫郪磁賦彆腔杅郪b
' 蚚衾刉恁齬唗綴祥笭葩賦彆腔趼萎d
' 郪磁賦彆唗瘍k
' 埻宎杅擂啋呧I湮跺杅m (森揭峈郔湮俴杅)
' 埻宎杅擂蹈杅n

Sub MultiColumnCombin() 'by kagawa 測鎢翋徹最
    Dim tms#
    tms = Timer
    sj = [a1].CurrentRegion
    m = UBound(sj): n = UBound(sj, 2)

    k = m ^ n '數呾郪磁賦彆郔湮褫夔杅k
    ReDim b(k, 1 To n) '擂森隅砱湔溫郪磁賦彆腔杅郪b
    Set d = CreateObject("Scripting.Dictionary") '膘蕾趼萎d

    k = 0: Call dgMN(1) 'k場宎趙 綴覃蚚菰寥徹最

    [h1].Offset.CurrentRegion = "" '諾怀堤郖
    [h1].Offset.Resize(k, n) = b       '怀堤祥笭葩郪磁賦彆

                                                              '怀堤杅趼齬唗綴腔祥笭葩郪磁賦彆

    MsgBox Format(Timer - tms, "0.000s ") & k & "/" & d.Count
    '最唗賦旰﹜勤趕遺珆尨ㄩ最唗瘧奀/郪磁賦彆軞杅k/齬唗祥笭葩跺杅
End Sub

Sub dgMN(j&) '菰寥呾楊徹最
    Dim i&, l&, t
    For i = 1 To m '梢盪掛蹈j蹈跪俴
        t = sj(i, j): If t = "" Then Exit For '彆蜆俴啋厤R諾寀豖堤
        If a(t) = "" Then '彆蜆杅趼帤掩妏蚚寀樟哿 / 瘁寀泐徹
            If j > 1 Then
               If t < b(k, j - 1) Then GoTo 1
            End If
            a(t) = t '婓杅郪a笢梓暮蜆杅趼t眒妏蚚
            b(k, j) = t '婓賦彆杅郪b腔勤茼蹈笢暮翹蜆杅趼t
            If j = n Then '&#63537;彆郪磁跺杅湛善n跺寀俇傖掛棒郪磁
                k = k + 1 '郪磁賦彆k+1
                For l = 1 To n - 1
                    b(k, l) = b(k - 1, l) '葩秶﹜樟創眈肮囀&#63527;善狟珨俴
                Next
                d(Join(a, "")) = "" '磁甜杅郪a笢腔賦彆腕善植苤善湮齬唗腔郪磁賦彆﹜蚚趼萎&#63471;笭葩
            Else '&#63537;郪磁跺杅<n 寀樟哿菰寥
                Call dgMN(j + 1) 'j+1撈褫輛&#63541;狟珨蹈
            End If
            a(t) = "" '掛棒菰寥數呾綴﹜豖堤奀剒猁參杅郪a笢腔暮翹珩&#63378;諾ㄛ眕晞狟珨棒陔腔郪磁褫眕妏蚚
        End If
1:
    Next
End Sub

祝順心，南無阿彌陀佛！

跳转到最佳答案楼层

cutecpu

加紅色部份而已

Dim sj, a(33), b(), d, k&, m&, n&
'隅砱菰寥剒猁腔鼠蚚曹講ㄩ
' 湔溫馱釬桶杅擂&#63397;郖腔媼峎杅郪sj
' 暮翹杅趼岆瘁笭葩腔杅郪a
' 湔溫郪磁賦彆腔杅郪b
' 蚚衾刉恁齬唗綴祥笭葩賦彆腔趼萎d
' 郪磁賦彆唗瘍k
' 埻宎杅擂啋呧I湮跺杅m (森揭峈郔湮俴杅)
' 埻宎杅擂蹈杅n

Sub MultiColumnCombin() 'by kagawa 測鎢翋徹最
    Dim tms#
    tms = Timer
    sj = [a1].CurrentRegion
    m = UBound(sj): n = UBound(sj, 2)

    k = m ^ n '數呾郪磁賦彆郔湮褫夔杅k
    ReDim b(k, 1 To n) '擂森隅砱湔溫郪磁賦彆腔杅郪b
    Set d = CreateObject("Scripting.Dictionary") '膘蕾趼萎d

    k = 0: Call dgMN(1) 'k場宎趙 &#63493;綴覃蚚菰寥徹最

    [h1].Offset.CurrentRegion = "" '&#63378;諾怀堤&#63397;郖
    [h1].Offset.Resize(k, n) = b       '怀堤祥笭葩郪磁賦彆

                                                              '怀堤杅趼齬唗綴腔祥笭葩郪磁賦彆

    MsgBox Format(Timer - tms, "0.000s ") & k & "/" & d.Count
    '最唗賦旰﹜勤趕遺珆尨ㄩ最唗瘧奀/郪磁賦彆軞杅k/齬唗祥笭葩跺杅
End Sub

Sub dgMN(j&) '菰寥呾楊徹最
    Dim i&, l&, t
    For i = 1 To m '梢盪掛蹈j蹈跪俴
        t = sj(i, j): If t = "" Then Exit For '&#63537;彆蜆俴啋厤R諾寀豖堤
        If a(t) = "" Then '&#63537;彆蜆杅趼帤掩妏蚚寀樟哿 / 瘁寀泐徹
            If j > 1 Then
               If t < b(k, j - 1) Then GoTo 1
            End If
            a(t) = t '婓杅郪a笢梓暮蜆杅趼t眒妏蚚
            b(k, j) = t '婓賦彆杅郪b腔勤茼蹈笢暮翹蜆杅趼t
            If j = n Then '&#63537;彆郪磁跺杅湛善n跺寀俇傖掛棒郪磁
                k = k + 1 '郪磁賦彆k+1
                For l = 1 To n - 1
                    b(k, l) = b(k - 1, l) '葩秶﹜樟創眈肮囀&#63527;善狟珨俴
                Next
                d(Join(a, "")) = "" '磁甜杅郪a笢腔賦彆腕善植苤善湮齬唗腔郪磁賦彆﹜蚚趼萎&#63471;笭葩
            Else '&#63537;郪磁跺杅<n 寀樟哿菰寥
                Call dgMN(j + 1) 'j+1撈褫輛&#63541;狟珨蹈
            End If
            a(t) = "" '掛棒菰寥數呾綴﹜豖堤奀剒猁參杅郪a笢腔暮翹珩&#63378;諾ㄛ眕晞狟珨棒陔腔郪磁褫眕妏蚚
        End If
1:
    Next
End Sub

祝順心，南無阿彌陀佛！

sanpiao

cutecpu 发表于 2021-7-31 23:04
加紅色部份而已

Dim sj, a(33), b(), d, k&, m&, n&

感谢老师

sanpiao

cutecpu 发表于 2021-7-31 23:04
加紅色部份而已

Dim sj, a(33), b(), d, k&, m&, n&

老师您看一下这样的组合没出现

cutecpu

sanpiao 发表于 2021-7-31 23:32
老师您看一下这样的组合没出现

A~F 列全部变成数字格式就可以了
您原本那边有数字又有文字格式

sanpiao

cutecpu 发表于 2021-8-1 01:56
A~F 列全部变成数字格式就可以了
您原本那边有数字又有文字格式

明白了老师

sanpiao

cutecpu 发表于 2021-8-1 01:56
A~F 列全部变成数字格式就可以了
您原本那边有数字又有文字格式

老师您好，您看数据能不实现这样的组合（AB两列算一组，CD两列算一组，EF两列算一组，按行进行组合）（当前面数与后面数相等或大于后面数时不组合）。模拟结果在右面

sanpiao

cutecpu 发表于 2021-7-31 23:04
加紅色部份而已

Dim sj, a(33), b(), d, k&, m&, n&

老师您看看：当前面数小于等于后面数时也排列组合。应该改代码的哪部

linuvzg

謝謝分享