求助：如何将字母根据出现次数随机分布到各列

larer

便胜晴天 发表于 2020-5-6 10:24
注意审题  题目已经说清楚  每列字母出现不能重复  假如A有3次  第1列出现了A  那么第1列就不能再出现A了 ...

表述的逻辑不严谨,容易引起歧义,应该表述为:"在右边的表格中随机填写字母A-J,使右边表格中A-J出现的次数符合AB列各字母出现次数的限制."

lsdongjh

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim arr As Variant, lngRow As Long
   
5.     Dim strChar As String, lngCount As Long
   
6.     Dim strAll As String, strSplit() As String
   
7.     Dim lngR_ID As Long, lngC_ID As Long
   
8.     Dim arrResult As Variant
   
9.    
   
10.     arr = Sheet1.Range("A2:B11")
    
11.    
    
12.     For lngRow = LBound(arr) To UBound(arr)
    
13.         strChar = Trim(arr(lngRow, 1))
    
14.         lngCount = Val(arr(lngRow, 2))
    
15.         strAll = strAll & Repeat(strChar, lngCount)
    
16.     Next
    
17.    
    
18.     strSplit = Split(strAll, "|")
    
19.     ReDim arrResult(1 To 5, 1 To 4)
    
20.    
    
21.     For lngRow = LBound(strSplit) To UBound(strSplit) - 1
    
22.         lngR_ID = (lngRow \ 4) + 1
    
23.         lngC_ID = (lngRow Mod 4) + 1
    
24.         
    
25.         If lngR_ID <= 5 And lngC_ID <= 4 Then
    
26.             arrResult(lngR_ID, lngC_ID) = strSplit(lngRow)
    
27.         End If
    
28.     Next
    
29.    
    
30.     Sheet1.Range("D2").Resize(5, 4) = arrResult
    
31. End Sub
    
32. 
    
33. Function Repeat(strTxt As String, lngNum As Long, Optional lngMax As Long = 4) As String
    
34.     Dim lngID As Long, strTemp As String
    
35.     strTxt = Trim(strTxt)
    
36.     If strTxt = "" Or lngNum <= 0 Then
    
37.         Repeat = ""
    
38.         Exit Function
    
39.     End If
    
40.    
    
41.     If lngNum > lngMax Then lngNum = lngMax
    
42.    
    
43.     For lngID = 1 To lngNum
    
44.         strTemp = strTemp & strTxt & "|"
    
45.     Next
    
46.     Repeat = strTemp
    
47. End Function

复制代码

便胜晴天

SaverTZ 发表于 2020-5-6 10:39
你要的表格

谢谢  但是测试了你的代码  好像次数会丢失哦  C的次数4次  然而右边只有2次  一共19个字母  最后组合出了17个字母 丢失2个

便胜晴天

lsdongjh 发表于 2020-5-6 11:20

谢谢  代码可以成功运行  唯一的不足之处就是每次产生的组合结果都相同  达不到题目说的随机的效果！

lsdongjh

便胜晴天 发表于 2020-5-6 22:55
谢谢  代码可以成功运行  唯一的不足之处就是每次产生的组合结果都相同  达不到题目说的随机的效果！

唉，不动脑，在拼装前，前原数组的顺序 乱序处理一下，就能达到随机的效果

yjh_27

便胜晴天 发表于 2020-5-6 22:55
谢谢  代码可以成功运行  唯一的不足之处就是每次产生的组合结果都相同  达不到题目说的随机的效果！

参见附件。

不是每次都成功，多按几次

SaverTZ

便胜晴天 发表于 2020-5-6 22:51
谢谢  但是测试了你的代码  好像次数会丢失哦  C的次数4次  然而右边只有2次  一共19个字母  最后组合 ...

那照这个逻辑的话，每一列都会必定有一个C，这样不就违背了随机这一说了吗，随机就是这一列可能出现C也可能不会出现C

SaverTZ

SaverTZ 发表于 2020-5-7 16:46
那照这个逻辑的话，每一列都会必定有一个C，这样不就违背了随机这一说了吗，随机就是这一列可能出现C也可 ...

那就要做两套逻辑，如果字母的数量=列数，就每一列都出现位置随机，反之按完全随机进行

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, a, b
  arr = [a2:b11].Value
  Call rnddata(arr, 1, UBound(arr, 1), 1, UBound(arr, 2))
  ReDim brr(1 To UBound(arr, 1), 1 To 4), m(UBound(brr, 2))
  a = 1: b = 0
  For i = 1 To UBound(arr, 1)
    For j = 1 To arr(i, 2)
      b = b + 1: m(b) = m(b) + 1
      brr(a, b) = arr(i, 1)
      If b = UBound(brr, 2) Then a = a + 1: b = 0
    Next
  Next
  For i = 1 To UBound(brr, 2)
    Call rnddata(brr, 1, m(i), i, i)
  Next
  [d2].Resize(UBound(brr, 1), UBound(brr, 2)) = brr
End Sub

Function rnddata(arr, first, last, left, right)
  Dim i As Long, j As Long, n As Long, cnt As Long, t
  cnt = last - first + 1
  Randomize
  For i = first To last
    n = Int(Rnd * cnt)
    For j = left To right
      t = arr(i, j): arr(i, j) = arr(first + n, j): arr(first + n, j) = t
    Next
  Next
End Function

便胜晴天

一把小刀闯天下 发表于 2020-5-8 12:09
Option Explicit

Sub test()

膜拜大佬！代码学习一下