设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 求一段排列代码
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1694|回复: 7

[已解决]求一段排列代码

[复制链接]
发表于 2013-7-30 09:45 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
有一个由30个字母组成的一串字符串，其元素可能是由n1个“A"、n2个“B"、n3个“C"、n4个“D"、n5个“E"、n6个“F"、n7个“G"、n8个“H"(所有的n都大于等于0)组成，也可能由n1个“A"、n2个“B"、n3个“C"、n4个“D"、n5个“E"、n6个“F"组成。（即字母种类不定、每个字母的个数不定，但整个字符串长度30是肯定的，如字串”AAAAAABBBBBCCCCCCDDDEEEFGGGHHH“。）
现希望得到由这些字母组成的一个排列，两条件要同时满足（便于叙述，将每个字符的位置依次编号为1、2、3、……28、29、30）：
条件一：处于第1至8位的，相邻的字母不能相同，即不能有”AAB“或”ABB“出现，而”ABA“是可以的。同样，处于第9至15位、第16至22位、第23至30位，相邻字母也不能相同。第8、9位不算相邻，所以可以相同（即8、9位可以为”AA“），第15与16位、第22与23位也不算相邻，所以也可以相同。
条件二：9位不能与1、2、3位相同，10位不能与2、3、4位相同，11位不能与3、4、5位相同，12位不能与4、5、6位相同，13位不能与5、6、7位相同，14位不能与6、7、8位相同，15位不能与7、8位相同;
     16位不能与9、10位相同，17位不能与9、10、11位相同，18位不能与10、11、12位相同，19位不能与11、12、13位相同，20位不能与12、13、14位相同，21位不能与13、14、15位相同，22位不能与14、15位相同;
     23位不能与16位相同，24位不能与16、17位相同，25位不能与16、17、18位相同，26位不能与17、18、19位相同，27位不能与18、19、20位相同，28位不能与19、20、21位相同，29位不能与20、21、22位相同，30位不能与21、22位相同.

以下是以字串”AAAAAABBBBBCCCCCCDDDEEEFGGGHHH“为例得到的一个结果：

2.jpg
望各位赐教，谢谢
最佳答案
月排行榜 / 总排行榜
wcymiss
2013-7-30 16:03
本帖最后由 wcymiss 于 2013-7-30 16:09 编辑
  1. Private arrResult(1 To 30) As String
  2. Private arrDicKeys()
  3. Private Success As Boolean
  4. Sub Main1() '回溯
  5.     Const strData As String = "AAAAAABBBBBCCCCCCDDDEEEFGGGHHH"
  6.     Dim objDic As Object
  7.     Dim i As Integer
  8.     Dim arrDicItems()
  9.    
  10.     Set objDic = CreateObject("scripting.dictionary")
  11.     For i = 1 To Len(strData)
  12.         objDic(Mid(strData, i, 1)) = objDic(Mid(strData, i, 1)) + 1
  13.     Next
  14.     arrDicKeys = objDic.keys '不重复字符列表
  15.     arrDicItems = objDic.items '每个字符个数
  16.     Set objDic = Nothing
  17.    
  18.     Call subProgram(1, arrDicItems)
  19.     If Success Then
  20.         MsgBox Join(arrResult, "")
  21.     Else
  22.         MsgBox "无法找到符合条件的字符串！"
  23.     End If
  24. End Sub
  25. Private Sub subProgram(ByVal intPos As Integer, ByVal arrLimit)
  26.     'intPos:字符位置
  27.     'arrLimit:每个字符的个数限制
  28.     Dim intKeyPos As Integer 'dickey的位置
  29.     Dim arrLimitTemp
  30.    
  31.     intKeyPos = -1
  32.    
  33.     Do
  34.         intKeyPos = intKeyPos + 1
  35.         If arrLimit(intKeyPos) = 0 Then
  36.             GoTo NEXTDO '已用光本字符，退出
  37.         End If
  38.         
  39.         arrResult(intPos) = arrDicKeys(intKeyPos) '选值
  40.         
  41.         If intPos <> 1 Then
  42.             If arrResult(intPos) = arrResult(intPos - 1) Then
  43.                 If intPos <> 9 And intPos <> 16 And intPos <> 23 Then '如果位置非9、16、23
  44.                     GoTo NEXTDO '相邻的字符一样，不符合，退出
  45.                 End If
  46.             End If
  47.         End If
  48.         
  49.         If intPos > 8 Then
  50.             If arrResult(intPos) = arrResult(intPos - 8) Then GoTo NEXTDO '不符合，退出
  51.             If arrResult(intPos) = arrResult(intPos - 7) Then GoTo NEXTDO '不符合，退出
  52.             If arrResult(intPos) = arrResult(intPos - 6) Then GoTo NEXTDO '不符合，退出
  53.         End If
  54.         
  55.         If intPos < 30 Then '未找满30个字符串则继续
  56.             arrLimitTemp = arrLimit
  57.             arrLimitTemp(intKeyPos) = arrLimit(intKeyPos) - 1
  58.             Call subProgram(intPos + 1, arrLimitTemp)
  59.         Else
  60.             Success = True
  61.         End If
  62. NEXTDO:
  63.     Loop Until Success Or intKeyPos = UBound(arrDicKeys)
  64. End Sub
复制代码
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
 楼主| 发表于 2013-7-30 09:57 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
不敢！
是真的遇到这个问题，一时没想到好的解决之道（递归？穷举？还是……），又需要这个，没法子了，才来求助于各位
{:4212:}
回复

使用道具 举报

 楼主| 发表于 2013-7-30 10:02 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
回溯得行不？算法没学好
回复

使用道具 举报

发表于 2013-7-30 10:16 | 显示全部楼层
哥们你不会是搞轮胎的吧^_^
回复

使用道具 举报

 楼主| 发表于 2013-7-30 11:22 | 显示全部楼层
suye1010 发表于 2013-7-30 10:16
哥们你不会是搞轮胎的吧^_^

条件是稍多了点。要是简化到只满足条件一呢？
回复

使用道具 举报

wcymiss
发表于 2013-7-30 16:03 | 显示全部楼层    本楼为最佳答案   
本帖最后由 wcymiss 于 2013-7-30 16:09 编辑
  1. Private arrResult(1 To 30) As String
  2. Private arrDicKeys()
  3. Private Success As Boolean
  4. Sub Main1() '回溯
  5.     Const strData As String = "AAAAAABBBBBCCCCCCDDDEEEFGGGHHH"
  6.     Dim objDic As Object
  7.     Dim i As Integer
  8.     Dim arrDicItems()
  9.    
  10.     Set objDic = CreateObject("scripting.dictionary")
  11.     For i = 1 To Len(strData)
  12.         objDic(Mid(strData, i, 1)) = objDic(Mid(strData, i, 1)) + 1
  13.     Next
  14.     arrDicKeys = objDic.keys '不重复字符列表
  15.     arrDicItems = objDic.items '每个字符个数
  16.     Set objDic = Nothing
  17.    
  18.     Call subProgram(1, arrDicItems)
  19.     If Success Then
  20.         MsgBox Join(arrResult, "")
  21.     Else
  22.         MsgBox "无法找到符合条件的字符串！"
  23.     End If
  24. End Sub
  25. Private Sub subProgram(ByVal intPos As Integer, ByVal arrLimit)
  26.     'intPos:字符位置
  27.     'arrLimit:每个字符的个数限制
  28.     Dim intKeyPos As Integer 'dickey的位置
  29.     Dim arrLimitTemp
  30.    
  31.     intKeyPos = -1
  32.    
  33.     Do
  34.         intKeyPos = intKeyPos + 1
  35.         If arrLimit(intKeyPos) = 0 Then
  36.             GoTo NEXTDO '已用光本字符，退出
  37.         End If
  38.         
  39.         arrResult(intPos) = arrDicKeys(intKeyPos) '选值
  40.         
  41.         If intPos <> 1 Then
  42.             If arrResult(intPos) = arrResult(intPos - 1) Then
  43.                 If intPos <> 9 And intPos <> 16 And intPos <> 23 Then '如果位置非9、16、23
  44.                     GoTo NEXTDO '相邻的字符一样，不符合，退出
  45.                 End If
  46.             End If
  47.         End If
  48.         
  49.         If intPos > 8 Then
  50.             If arrResult(intPos) = arrResult(intPos - 8) Then GoTo NEXTDO '不符合，退出
  51.             If arrResult(intPos) = arrResult(intPos - 7) Then GoTo NEXTDO '不符合，退出
  52.             If arrResult(intPos) = arrResult(intPos - 6) Then GoTo NEXTDO '不符合，退出
  53.         End If
  54.         
  55.         If intPos < 30 Then '未找满30个字符串则继续
  56.             arrLimitTemp = arrLimit
  57.             arrLimitTemp(intKeyPos) = arrLimit(intKeyPos) - 1
  58.             Call subProgram(intPos + 1, arrLimitTemp)
  59.         Else
  60.             Success = True
  61.         End If
  62. NEXTDO:
  63.     Loop Until Success Or intKeyPos = UBound(arrDicKeys)
  64. End Sub
复制代码

点评

上清宫主
真给力！！！！！！！！  发表于 2013-7-30 16:23

评分

参与人数 1 +10 收起 理由
上清宫主 + 10 赞一个!

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2013-7-30 16:23 | 显示全部楼层
非常感谢！
仔细研究研究
回复

使用道具 举报

发表于 2013-7-30 18:37 | 显示全部楼层
我也要好好研究一下{:3912:}
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-5-20 11:57 , Processed in 0.242860 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表