|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Option Explicit
Sub test()
Dim ar, br, cr, vResult(), i&, j&, n&, Rng As Range
Dim dic As Object, isFlag As Boolean, iPosCol&
Application.ScreenUpdating = False
ReDim ar(1 To 5)
For i = 1 To 5
ar(i) = i
Next i
ar = ArrPermut(ar, 5)
Set dic = CreateObject("Scripting.Dictionary")
Columns("X:XDF").Clear
Set Rng = [C3:G7]
br = Rng.Value
With Rng
For i = 1 To UBound(ar)
dic.RemoveAll: isFlag = True
For j = 1 To UBound(ar, 2)
If Not dic.exists(br(j, ar(i, j))) Then
dic(br(j, ar(i, j))) = Array(.Cells(j, ar(i, j)).Address(0, 0), j, ar(i, j))
Else
isFlag = False: Exit For
End If
Next j
If isFlag Then
n = n + 1
iPosCol = (n - 1) * 6 + 1 + 23
Rng.Copy Cells(19, iPosCol)
With Cells(19, iPosCol)
ReDim Preserve vResult(1 To 5, 1 To n)
For j = 0 To dic.Count - 1
cr = dic.items()(j)
vResult(j + 1, n) = cr(0)
.Cells(cr(1), cr(2)).Interior.Color = vbGreen
Next j
End With
End If
Next i
End With
If n Then [X1].Resize(5, n) = vResult
Application.ScreenUpdating = True
Beep
End Sub
Function ArrPermut(ar, n&)
Dim br&(), cr&(), vResult, i&, j&, k&, m&, iGroup&
m = UBound(ar)
iGroup = WorksheetFunction.Permut(m, n)
ReDim br&(1 To n), cr&(1 To m), vResult(1 To iGroup, 1 To n)
For j = 1 To n
br(j) = j: cr(j) = 1
vResult(1, j) = ar(j)
Next
For i = 2 To iGroup
For j = n To 1 Step -1
cr(br(j)) = 0
For k = br(j) + 1 To m
If cr(k) = 0 Then Exit For
Next
If k <= m Then cr(k) = 1: br(j) = k: Exit For
Next
For j = j + 1 To n
For k = 1 To m
If cr(k) = 0 Then Exit For
Next
cr(k) = 1: br(j) = k
Next
For j = 1 To n
vResult(i, j) = ar(br(j))
Next
Next
ArrPermut = vResult
End Function
|
评分
-
1
查看全部评分
-
|