Sub 準2進3()
Dim Arr, Arr1, Brr, xD, xD1, T, T1, k%, i&, j&
Arr = Range([ae2], [ak65536].End(3)) '資料裝入數組
Arr1 = Range([an2], [at65536].End(3)) '資料裝入數組
ReDim Brr(1 To UBound(Arr), 1 To 7) '預設答案數組
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
'將數組的最後一列資料裝到字典
For i = UBound(Arr) To UBound(Arr)
For j = 1 To 7: xD(Arr(i, j) & "") = "": Next
Next
For i = UBound(Arr1) To UBound(Arr1)
For j = 1 To 7: xD1(Arr1(i, j) & "") = "": Next
Next
'開始比對
For i = 1 To UBound(Arr): For j = 1 To UBound(Arr, 2)
T = Arr(i, j): T1 = Arr1(i, j)
For k = 0 To 48
a = (T + k) Mod 49: a1 = (T1 + k) Mod 49 'a:MOD(AE2+k,49)的餘數
If xD.Exists(a & "") And xD1.Exists(a1 & "") Then '2邊餘數都有在各別字典
If Brr(i, j) = "" Then '將k裝入Brr
Brr(i, j) = k
Else
Brr(i, j) = Brr(i, j) & "," & k
End If
End If
Next
Next: Next
Range("V2").Resize(UBound(Brr), 7) = Brr
End Sub作者: samwang 時間: 2021-7-22 12:01
Sub TEST()
Dim xS As Worksheet, xD, Arr(6), Brr, R&, i&, j%, k%, x%, N%, T$
Set xD = CreateObject("Scripting.Dictionary")
For Each xS In Sheets(Array("準2進3", "準3進4", "準4進5", "準5進6", "準6進7", "準7進8"))
xD.RemoveAll
R = xS.[ac65536].End(xlUp).Row - 1
N = N + 1: If R < 1 Then GoTo s01
ReDim Brr(1 To R - 1, 1 To 7)
For k = 0 To N
Arr(k) = xS.[ae2].Cells(1, k * 9 + 1).Resize(R, 7)
For j = 1 To 7
xD(Arr(k)(R, j) & "|" & k) = 1
Next j
Next k
'--------------------------------------
For i = 1 To R - 1
For j = 1 To 7
For x = 0 To 48
For k = 0 To N
T = (Arr(k)(i, j) + x) Mod 49 & "|" & k
If xD(T) = 0 Then GoTo x001
Next k
Brr(i, j) = Brr(i, j) & IIf(Brr(i, j) = "", "", ",") & x
x001: Next x
Next j
Next i
'-------------------------------------
With xS.[v2].Resize(R - 1, 7)
.NumberFormatLocal = "@"
.Value = Brr
End With
s01: Next
End Sub
