求组组合公式或宏代码

hui123789aim · 发表于 2023-10-27 13:11

本帖最后由 hui123789aim 于 2023-10-27 13:16 编辑

[tr]  [td=321]JHS69-abx-c-y[/td] [/tr]
[tr]  [td][/td] [/tr]
[tr]  [td]a= PM, DB, DC, EM, HM, LK,  EL [/td] [/tr]
[tr]  [td]b = 20, 25, 32, 40 [/td] [/tr]
[tr]  [td]C = 2 [/td] [/tr]
[tr]  [td]X = R, Blank [/td] [/tr]
[tr]  [td]y = RY48, RY64, B48, B64,  Blank[/td] [/tr]
[tr]  [td][/td] [/tr]
[tr]  [td][/td] [/tr]
[tr]  [td][/td] [/tr]
[tr]  [td][/td] [/tr]
[tr]  [td][/td] [/tr]
[tr]  [td][/td] [/tr]
[tr]  [td]最后组成JHS69-PM20r-2-RY48[/td] [/tr]
[tr]  [td]….[/td] [/tr]
[tr]  [td]需要全部可能自动项列出来，公式或者宏代码[/td] [/tr]

vba新手016 · 发表于 2023-10-30 15:31

本帖最后由 vba新手016 于 2023-10-30 15:33 编辑

组合.zip (20.09 KB, 下载次数: 8)

林木水123 · 发表于 2023-11-8 15:00

Option Compare Text
Sub 林木水demo()
Dim a, b, c, x, y, i As Integer, temp, sr
a = Array("PM", "DB", "DC", "EM", "HM", "LK", "EL")
b = Array(20, 25, 32, 40)
c = Array(2)
x = Array("R", "Blank")
y = Array("RY48", "RY64", "B48", "B64", "Blank")
f = "JHS69-abx-c-y"
Dim arr(), k, j, z, m, j1, brr
z = 1
For i = 1 To Len(f)
m = z
ReDim Preserve arr(1 To m)
temp = Mid(f, i, 1)
If temp Like "a" Then
m = z
z = z * (UBound(a) + 1)
k = 0
brr = arr
For j = 1 To m
For j1 = 0 To UBound(a)
k = k + 1
ReDim Preserve arr(1 To k)
arr(k) = brr(m) & a(j1)
Next
Next
ElseIf temp Like "b" Then
m = z
z = z * (UBound(b) + 1)
k = 0
brr = arr
For j = 1 To m
For j1 = 0 To UBound(b)
k = k + 1
ReDim Preserve arr(1 To k)
arr(k) = brr(m) & b(j1)
Next
Next
ElseIf temp Like "c" Then
m = z
z = z * (UBound(c) + 1)
k = 0
brr = arr
For j = 1 To m
For j1 = 0 To UBound(c)
k = k + 1
ReDim Preserve arr(1 To k)
arr(k) = brr(m) & c(j1)
Next
Next
ElseIf temp Like "X" Then
m = z
z = z * (UBound(x) + 1)
k = 0
brr = arr
For j = 1 To m
For j1 = 0 To UBound(x)
k = k + 1
ReDim Preserve arr(1 To k)
arr(k) = brr(m) & x(j1)
Next
Next
ElseIf temp Like "y" Then
m = z
z = z * (UBound(y) + 1)
k = 0
brr = arr
For j = 1 To m
For j1 = 0 To UBound(y)
k = k + 1
ReDim Preserve arr(1 To k)
arr(k) = brr(m) & y(j1)
Next
Next
Else
m = z
For j = 1 To m
arr(j) = arr(j) & temp
Next
End If
Next
Range("I1").Resize(UBound(arr), 1) = Application.Transpose(arr)
End Sub

复制代码

林木水123 · 发表于 2023-11-8 15:03

结果展示

xhc123456789 · 发表于 2023-11-15 19:34

本帖最后由 xhc123456789 于 2023-11-15 19:39 编辑

Dim d As Object, darr As Object          '''''''''''公共函数

Sub sss() '''''''''触发递归程序
Dim f As String
Set d = CreateObject("scripting.dictionary")
Set darr = CreateObject("scripting.dictionary")
d("a") = Array("PM", "DB", "DC", "EM", "HM", "LK", "EL")
d("b") = Array(20, 25, 32, 40)
d("c") = Array(2)
d("x") = Array("R", "Blank")
d("y") = Array("RY48", "RY64", "B48", "B64", "Blank")
f = "JHS69-abx-c-y"
Getarr f, ""
Selection.range("a1").Resize(darr.Count) = Application.Transpose(darr.keys)
End Sub

Sub Getarr(txt As String, txts As String)  '''''''''递归程序
If Len(txt) = 0 Then darr(txts) = 1:DoEvents : Exit Sub
If d.exists(Left(txt, 1)) Then
For Each a In d(Left(txt, 1))
      Getarr Mid(txt, 2, Len(txt)), txts & a
Next
Else
      Getarr Mid(txt, 2, Len(txt)), txts & Left(txt, 1)
End If
End Sub

		自动登录	找回密码
密码			注册

求组 组合公式或宏代码

求组组合公式或宏代码