按既定规则穷举排列的算法

regtled

问题：
A列，B列，C列均为字符，举例如下所示

A	B	C
红	软	苹果
橙	硬	香蕉
	粗	梨
	细	橘子
		哈密瓜
		桃子
		榴莲
		芋头
		西瓜
		橙子
		水蜜桃

需要穷举排列出所有组合（包括带空格与不带空格的情况），如下图所示



且要求：
1、去掉所有排列组合中不含有A的（图中灰色背景的组合）；
2、最终的输出把所有的穷举排列输出为一列（顺序不重要）

请问各位高手这样的问题可以用VBA解决么？（原始excel文件请见附件）

regtled

附件

hfwufanhf2006

做肯定能做出来，就是排列组合的事，你这个有顺序，是排列。

Columns("h:h").Clear
Dim arr1
Dim arr2
Dim arr3
arr1 = Range("a2:a" & [a10000].End(3).Row)
arr2 = Range("b2:b" & [b10000].End(3).Row)
arr3 = Range("c2:c" & [c10000].End(3).Row)
hs = 1
For n = 1 To 6
    Dim brr1
    Dim brr2
    Dim brr3
    If n = 1 Then
       brr1 = arr1
       brr2 = arr2
       brr3 = arr3
    End If
    If n = 2 Then
       brr1 = arr1
       brr2 = arr3
       brr3 = arr2
    End If
    If n = 3 Then
       brr1 = arr2
       brr2 = arr1
       brr3 = arr3
    End If
    If n = 4 Then
       brr1 = arr2
       brr2 = arr3
       brr3 = arr1
    End If
    If n = 5 Then
       brr1 = arr3
       brr2 = arr1
       brr3 = arr2
    End If
    If n = 6 Then
       brr1 = arr3
       brr2 = arr2
       brr3 = arr1
    End If
    For i = 1 To UBound(brr1)
        s1 = brr1(i, 1)
        For k = 0 To UBound(brr2)
            If k = 0 Then
               s2 = " "
            Else
               s2 = brr2(k, 1)
            End If
            For j = 0 To UBound(brr3)
                If j = 0 Then
                   s3 = " "
                Else
                   s3 = brr3(j, 1)
                End If
                s = s1 & s2 & s3
                Cells(hs, 8) = s
                hs = hs + 1
            Next
       Next
   Next
   Erase brr1
   Erase brr2
   Erase brr3
Next n

0126

regtled 发表于 2020-8-5 22:09
附件

Dim dic As Object, c As Long
Sub sd()
Dim arr, d As Object, x As Long, y As Long, le, rg, st As String, saverange As Range
Set dic = CreateObject("scripting.dictionary"): Set dic(0) = CreateObject("scripting.dictionary"): c = 0   '公共变量声明

Set d = CreateObject("scripting.dictionary")
arr = ActiveSheet.Range("a1").CurrentRegion.Offset(1)                             ''''''''''需组合数据
Set saverange = ActiveSheet.Cells(2, UBound(arr, 2) + 4)  ''''结果保存单元格

For y = 1 To 26                                                                    ''''''''''设置最多组合列仅有26列
    If y > (1 + UBound(arr, 2) - LBound(arr, 2)) Then Exit For Else Set d(Chr(y + 64)) = CreateObject("scripting.dictionary")  '判断需组合列字典是否全部创建，创建完退出创建
    For x = LBound(arr) To UBound(arr)                                            ''''''''''循环组合值放入对应列字典,
        st = arr(x, y + LBound(arr, 2) - 1): If Len(st) > 0 Then d(Chr(y + 64))(x) = st Else Exit For
    Next
Next

   For Each le In Array(1, 2, 3, 4)                                                 ''''''''''需组合列个数
       Call combin(join(d.keys, ""), CByte(le), 1, "", "A")                      ''''''''''使用combin程序组合列
       arr = dic(0).keys: dic(0).RemoveAll                                        ''''''''''获取放入公共字典的组合，在清空数据，以免之后数据错误
             For y = 0 To 2 ^ (le - 1) - 1                                        ''''''''''计算在当前（组合列个数）不同地方插入空格所需次数 循环
                 st = WorksheetFunction.Dec2Bin(y, le)                            ''''''''''转换y值为二进制，方便插入空格，
                 For Each rg In arr                                               ''''''''''提取组合结果，用combin2程序转换为对应值并插入空格
                     Call combin2(d, CStr(rg), 1, "", st)
                 Next
             Next
    Next

    dic.Remove 0: saverange.EntireColumn = "": saverange.Offset(-1) = "结果"          ''''删除combin程序使用的数据字典，清空结果列
    If dic.Count < 70000 Then  ''''''''''''''''''''''''''''我这边用转置函数Application.Transpose转置7万多行数据时发生错误，暂时不清楚原因，所以判断多余的话使用循环放入数组填充吧
       saverange.Resize(dic.Count) = Application.Transpose(dic.items)
    Else
       ReDim arr(1 To dic.Count, 1 To 1) As String: x = 0                        ''''''''''声明二维数组,提取字典数据填充
       For Each rg In dic.items
           x = x + 1: arr(x, 1) = rg
       Next
       saverange.Resize(dic.Count) = arr
    End If
End Sub
Sub combin(a As String, le As Byte, l As Byte, joinst As String, include As String) ''''''''''''''''''把列字符组合成不同顺序，并去除不包含A列的组合
Dim x As Long
    If l < le Then
        For x = 1 To Len(a)
            Call combin(Replace(a, Mid(a, x, 1), ""), le, l + 1, joinst & Mid(a, x, 1), include)
        Next
    Else
        If VBA.InStr(joinst, include) Then  '''''''''''''''''''判断是否包含，不包含直接连接对应值结束，
            For x = 1 To Len(a)
                dic(0)(joinst & Mid(a, x, 1)) = ""
            Next
        Else
            dic(0)(joinst & include) = ""
        End If
    End If
End Sub
Sub combin2(d As Object, a As String, l As Byte, joinst As String, sep As String)  ''''''''''''''''''''''转换列字符为对应值并加空格
Dim rg
    If l < Len(a) Then
        For Each rg In d(Mid(a, l, 1)).items
            Call combin2(d, a, l + 1, joinst & IIf(Mid(sep, l, 1) + 0, " ", "") & rg, sep)
        Next
    Else
        For Each rg In d(Mid(a, l, 1)).items
            c = c + 1: dic(c) = joinst & IIf(Mid(sep, l, 1) + 0, " ", "") & rg
        Next
    End If
End Sub