取得指定範圍內的各k值 - Excel程式區

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

1^# 跳轉到 »

發表於 2021-7-21 14:14 | 顯示全部帖子

回復 1# ziv976688

很難理解您的需求，可以解釋詳細一點嗎? 謝謝

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

2^#

發表於 2021-7-21 21:20 | 顯示全部帖子

回復 5# ziv976688

看到您可以寫到這樣真的好厲害，看得都眼花，我會試著解讀您的意思，謝謝

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-1-10

3^#

發表於 2021-7-22 11:40 | 顯示全部帖子

本帖最後由 samwang 於 2021-7-22 11:46 編輯

回復 7# ziv976688

請先測試看看是否為您的需求，下面只是準2進3，如果沒問題請您自行修改程式給其它工作表，感謝。

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

TOP

samwang