VBA比對求解

n7822123

　暱稱: 阿龍

中學生 Rank: 2

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

3^#

發表於 2019-6-14 02:26 | 只看該作者

本帖最後由 n7822123 於 2019-6-14 02:28 編輯

回復 1# peter631114

希望我的理解沒有錯，請試試看吧!

Sub 比對()
Dim Ri&, Rn&, i&, j&, n&, Arr, Brr
Ri = Cells(Rows.Count, 1).End(3).Row
Arr = [A2].Resize(Ri - 1, 2)
Rn = Ri * (Ri - 1)
If Rn >= Rows.Count Then Rn = Rows.Count - 1
Brr = [K2].Resize(Rn, 3): n = 1
For i = 1 To Ri - 1: For j = 1 To Ri - 1
  If i <> j Then
   If Arr(i, 2) = Arr(j, 2) Then
      Brr(n, 1) = Arr(i, 1)
      Brr(n, 3) = Arr(j, 1)
      n = n + 1
   Else: Exit For: End If
  End If
Next:  Next
[K2].Resize(Rn, 3) = Brr
End Sub

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

帖子: 18
主題: 6
精華: 0
積分: 24
點名: 0
作業系統: Windows
軟體版本: s
閱讀權限: 10
註冊時間: 2018-5-7
最後登錄: 2022-8-9

論壇榮譽勳章論壇贊助勳章

4^#

發表於 2019-6-14 10:22 | 只看該作者

Dear Sir
如你所了解沒有錯,我試用了你的code進行測試,結果是對的~~只是目前程式只有比對到判斷條件為0的部分,當判斷條件為"1"或2以後就沒有比對了~~

n7822123

　暱稱: 阿龍

中學生 Rank: 2

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

5^#

發表於 2019-6-14 11:09 | 只看該作者

回復 4# peter631114

不太懂你的意思，我程式跑出來的結果，跟你的敘述是一樣的

比對.rar (19.93 KB)

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

帖子: 18
主題: 6
精華: 0
積分: 24
點名: 0
作業系統: Windows
軟體版本: s
閱讀權限: 10
註冊時間: 2018-5-7
最後登錄: 2022-8-9

論壇榮譽勳章論壇贊助勳章

6^#

發表於 2019-6-14 13:26 | 只看該作者

Dear Sir

請參考下圖所示,程式會一直判斷,直到B欄位為空白才會停止
謝謝你的大力幫忙

0614_比對.rar (18.65 KB)

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-23

7^#

發表於 2019-6-14 17:59 | 只看該作者

類別判斷條件
A 0
B 0
C 0
D 2
F 2
G 2
H 0
I 0
J 2
K 2
L 2

這要如何比對??

==============

帖子: 18
主題: 6
精華: 0
積分: 24
點名: 0
作業系統: Windows
軟體版本: s
閱讀權限: 10
註冊時間: 2018-5-7
最後登錄: 2022-8-9

論壇榮譽勳章論壇贊助勳章

8^#

發表於 2019-6-17 10:22 | 只看該作者

Dear大大
請參考下圖比對結果,詳細內容請參考附件

[attachimg]30884

0617比對結果.rar (6.79 KB)
[/attachimg]

Snap3.jpg (106.27 KB)

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-23

9^#

發表於 2019-6-17 20:10 | 只看該作者

回復 8# peter631114

Sub TEST()
Dim Arr, Brr, i&, j&, N&
Arr = Range([B1], Cells(Rows.Count, 1).End(xlUp))
ReDim Brr(1 To 20000, 1 To 3)
For i = 2 To UBound(Arr)
For j = 2 To UBound(Arr)
      If i <> j And Arr(i, 2) = Arr(j, 2) Then
         N = N + 1
         Brr(N, 1) = Arr(i, 1)
         Brr(N, 3) = Arr(j, 1)
      End If
Next j
Next i
If N = 0 Then Exit Sub
[F2:H2].Resize(N) = Brr
End Sub

Xl0000362.rar (12.25 KB)

======================

帖子: 18
主題: 6
精華: 0
積分: 24
點名: 0
作業系統: Windows
軟體版本: s
閱讀權限: 10
註冊時間: 2018-5-7
最後登錄: 2022-8-9

論壇榮譽勳章論壇贊助勳章

10^#

發表於 2019-6-18 10:16 | 只看該作者

謝謝大大的幫忙,感恩喔