用于创建组合的VBA宏 [英] VBA Macro for creating combinations

问题描述

我正在尝试为下面提到的情况编写一个宏.

输入为:

 颜色A颜色B甲乙A CDABC ED AD BA 

我正在尝试进行以下组合输出:

  A B D AA C AA C B D A证书B D BC A B D A CC A CC B D A CC E A C||| 

以此类推

输出可以在同一工作表上.

输出应具有相同的起点和终点.循环应从第一行开始，并以起点和终点相同的方式寻找组合.

我只是无法弄清楚如何创建这样的循环.

请提出一些想法.

解决方案

有向图，避免循环和递归.美丽的挑战.代码需要大量改进，但现在是凌晨1点，我不得不在家中安装Excel:/

我假设您的数据在A1:B9范围内.解决方案打印在立即窗口"中(由您自行设置格式).

 选项显式子EveningFun()Dim rCell作为范围调光范围昏暗的目标作为字符串Dim availablePaths(1到9)为布尔值昏暗的整数对于i = 1到9availablePaths(i)=真接下来我设置rRng = Sheet1.Range("A1:A9")对于rRng.Cells中的每个rCell目标= rCell.value调用RecursiveFun(目标，rCell.Offset(0，1).值，目标，availablePaths)下一个rCell结束子Sub RecursiveFun(目标为字符串，nextElement为字符串，path为字符串，availablePaths()为布尔值)Dim rCell作为范围调光范围设置rRng = Sheet1.Range("A1:A9")对于rRng.Cells中的每个rCell如果目标= nextElement，则'Debug.Print路径&nextElementRange("D"& Rows.Count).End(xlUp).Cells.Offset(1，0)=路径&nextElement退出子万一如果nextElement = rCell.value和availablePaths(rCell.Row)然后将onePathLess(1到9)调暗为布尔值呼叫CopyArrays(availablePaths()，onePathLess())'一些关键的地方，我们必须避免周期onePathLess(rCell.Row)=假调用RecursiveFun(goal，rCell.Offset(0，1).value，path& nextElement，onePathLess())万一下一个rCell结束子Sub CopyArrays(source()As Boolean，target()As Boolean)昏暗的整数对于i = 1到9目标(i)=来源(i)接下来我结束子 

+4用于完成非常艰巨的任务，而-3用于不尝试.

I am trying to write a macro for the below mentioned situation.

The input is:

Col A   Col B
A       B
A       C
B       D
C       A
C       B
C       E
D       A
D       B
E       A

I am trying to make combinations such as Output:

A   B   D   A       
A   C   A           
A   C   B   D   A   
A   C   E   A       
B   D   B           
C   A   B   D   A   C
C   A   C           
C   B   D   A   C   
C   E   A   C

|
|
|

and so on

The output can be on the same worksheet.

The output should have the starting point and ending point as the same. The loop should start with first row and look for combinations in such a way that the starting point and ending point is the same.

I am simply unable to figure out, how to create a loop like this.

Please suggest some ideas.

解决方案

Directed graphs, avoiding cycles and recursion. Beautiful challenge. Code need a lot of improvements but is 1 am and I had to install Excel at home :/

I have assumed that you data are in range A1:B9. Solution is printed in Immediate Window( work of format by your self).

Option Explicit

Sub EveningFun()

    Dim rCell As Range
    Dim rRng As Range

    Dim goal As String

    Dim availablePaths(1 To 9) As Boolean

    Dim i As Integer

    For i = 1 To 9
        availablePaths(i) = True
    Next i


    Set rRng = Sheet1.Range("A1:A9")

    For Each rCell In rRng.Cells
        goal = rCell.value

        Call RecursiveFun(goal, rCell.Offset(0, 1).value, goal, availablePaths)

    Next rCell

End Sub

Sub RecursiveFun(goal As String, nextElement As String, path As String, availablePaths() As Boolean)

    Dim rCell As Range
    Dim rRng As Range

    Set rRng = Sheet1.Range("A1:A9")

    For Each rCell In rRng.Cells

        If goal = nextElement Then
            'Debug.Print path & nextElement
             Range("D" & Rows.Count).End(xlUp).Cells.Offset(1, 0) = path & nextElement
             Exit Sub
        End If

        If nextElement = rCell.value And availablePaths(rCell.Row) Then
            Dim onePathLess(1 To 9) As Boolean
            Call CopyArrays(availablePaths(), onePathLess())
            'some key place, we have to avoid cycles
            onePathLess(rCell.Row) = False

            Call RecursiveFun(goal, rCell.Offset(0, 1).value, path & nextElement, onePathLess())
        End If

    Next rCell

End Sub

Sub CopyArrays(source() As Boolean, target() As Boolean)

    Dim i As Integer

    For i = 1 To 9
        target(i) = source(i)
    Next i

End Sub

+4 for very great task but -3 for not trying.

这篇关于用于创建组合的VBA宏的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！