每个单元格取一个数并组合起来

不可说7625 · 发表于 2024-4-22 17:48

ykcbf1100 发表于 2024-4-22 16:53
这个用到了数组排序。

最开始的A7结果没问题，A8结果不是我想要的，

A8的结果是组合后里面的数字再排序，00111 01113 01116

把里面结果的都进行升序排序。

ykcbf1100 · 发表于 2024-4-22 18:42

不可说7625 发表于 2024-4-22 17:48
最开始的A7结果没问题，A8结果不是我想要的，

A8的结果是组合后里面的数字再排序，00111 01113 01116
...

让其他人来吧，我不想再跟进了。

baofa2 · 发表于 2024-4-22 19:31

Sub test0() '凭个人兴趣，纯练习，仅测试，无它，若要换写法，不回……
Dim i As Long, j As Long
Dim ar, br() As String, cr(4), dict As Object
Dim Conn As Object, strConn As String, SQL As String
ar = Range("A1").Resize(5)
ReDim br(1 To UBound(ar), 1 To Len(ar(1, 1)))
For i = 1 To UBound(ar)
For j = 1 To Len(ar(i, 1))
br(j, i) = Mid(ar(i, 1), j, 1)
Next
Next
Range("B1").Resize(i - 1, j - 1) = br
Set Conn = CreateObject("ADODB.Connection")
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source="
Conn.Open strConn & ThisWorkbook.FullName
SQL = "SELECT b.*,c.*,d.*,e.*,f.* FROM [$F1:F5] f,[$E1:E5] e,[$D1:D5] d,[$C1:C5] c,[$B1:B5] b"
ar = Conn.Execute(SQL).GetRows
Conn.Close
Set Conn = Nothing
ReDim br(UBound(ar, 2))
Set dict = CreateObject("Scripting.Dictionary")
For j = 0 To UBound(ar, 2)
For i = 0 To UBound(ar)
cr(i) = ar(i, j)
Next
br(j) = Join(cr, "")
QuickSort cr, LBound(cr), UBound(cr)
If Not dict.Exists(Join(cr, "")) Then dict.Add Join(cr, ""), ""
Next
Range("A1").CurrentRegion.Offset(, 1).ClearContents
Range("A7") = Join(br, vbCrLf)
Range("A8") = Join(dict.Keys, vbCrLf)
Set dict = Nothing
Beep
End Sub
Function QuickSort(ar, l As Long, u As Long)
Dim i As Long, j As Long, pivot As Long, swap As Long
If l >= u Then Exit Function
pivot = ar(l)
i = l + 1
j = u
Do
Do
If ar(i) > pivot Then Exit Do
i = i + 1
Loop While i <= u
Do
If ar(j) < pivot Then Exit Do
j = j - 1
Loop While j > l
If i >= j Then Exit Do
swap = ar(i)
ar(i) = ar(j)
ar(j) = swap
Loop
If l <> j Then
swap = ar(l)
ar(l) = ar(j)
ar(j) = swap
End If
If l < j Then QuickSort ar, l, j
If j + 1 < u Then QuickSort ar, j + 1, u
End Function

复制代码

ooluckydog · 发表于 2024-4-22 20:18

gwjkkkkk · 发表于 2024-4-22 20:50

Option Explicit
Sub test()
Dim ar, br, cr, i&, j&, dic As Object, strJoin$

Set dic = CreateObject("Scripting.Dictionary")

br = [A1].Resize(5).Value
ReDim ar(1 To UBound(br))
For i = 1 To UBound(br)
      ReDim cr(1 To Len(br(i, 1)), 1 To 1)
      For j = 1 To UBound(cr)
         cr(j, 1) = Mid(br(i, 1), j, 1)
      Next j
      ar(i) = cr
Next i

ar = cartesianProduct1(ar)
For i = 1 To UBound(ar)
      If i = 1 Then strJoin = Join(ar(i), "") Else strJoin = strJoin & vbCrLf & Join(ar(i), "")
      qSort1 ar(i), 1, UBound(ar(i))
      dic(Join(ar(i), "")) = Empty
Next i

[A7].Value = strJoin
br = dic.keys
qSort1 br, 0, UBound(br)
[A8].Value = Join(br, vbCrLf)
Beep
End Sub

Function qSort1(ByRef ar, ByVal iFirst&, ByVal iLast&, _
Optional ByVal isOrder As Boolean = True)

Dim i&, j&, k&, vTemp1, vTemp2

i = iFirst: j = iLast: vTemp1 = ar((iFirst + iLast) / 2)
While i <= j
      If isOrder Then
         While ar(i) < vTemp1: i = i + 1: Wend
         While vTemp1 < ar(j): j = j - 1: Wend
      Else
         While ar(i) > vTemp1: i = i + 1: Wend
         While vTemp1 > ar(j): j = j - 1: Wend
      End If
      If i <= j Then
         vTemp2 = ar(i): ar(i) = ar(j): ar(j) = vTemp2
         i = i + 1: j = j - 1
      End If
Wend

If iFirst < j Then qSort1 ar, iFirst, j, isOrder
If i < iLast Then qSort1 ar, i, iLast, isOrder
End Function
Function cartesianProduct1(ByVal ar) As Variant
Dim br&(), cr, vResult(), iGroup&, i&, j&, m&, n&, x&

n = UBound(ar)
For i = 1 To UBound(ar)
      m = m + UBound(ar(i), 2)
Next i
ReDim br(1 To n)
ReDim cr(1 To m)
For j = 1 To n: br(j) = 1: Next

iGroup = 0
Do
      x = 0
      For j = 1 To n
         For i = 1 To UBound(ar(j), 2)
            x = x + 1
            cr(x) = ar(j)(br(j), i)
         Next i
      Next
      iGroup = iGroup + 1
      ReDim Preserve vResult(1 To iGroup)
      vResult(iGroup) = cr
      For j = n To 1 Step -1
         br(j) = br(j) + 1
         If br(j) <= UBound(ar(j)) Then Exit For Else br(j) = 1
      Next
Loop Until j = 0

cartesianProduct1 = vResult
End Function