2

VBA-只保留不重複的值

錦子
個人積分：2084分
文章編號：80020388

2084分

11樓

2020-12-03 18:59

D2:
=SUMPRODUCT(($A$2:$A$20=A2)*($C$2:$C$20=C2)*1)
再複製到D3:D20
E2:
=IFERROR(OFFSET($A$1,SUMPRODUCT(LARGE(($D$2:$D$20=1)*ROW($D$2:$D$20),COUNTIF($D$2:$D$20,1)+2-ROW()))-1,COLUMN()-5),"")
再複製到E2:G20

錦色如月，子耀光芒。

misser

misser
個人積分：395分
文章編號：80020973

395分

12樓

2020-12-03 20:00

sun1027 wrote:
這位大大
跪求如何迎刃而解
我想破頭還是無解
T_T

呃，千萬別跪..........
用VBA寫一個簡單的範例給您參考：
結果：

程式碼：


Sub remove_2()

Dim d As Object, arr1
Set d = CreateObject("scripting.dictionary")
arr1 = [a1].CurrentRegion

For i = 1 To UBound(arr1)
    If d(arr1(i, 1) & arr1(i, 3)) = 0 Then d(arr1(i, 1) & arr1(i, 3)) = -1 Else d(arr1(i, 1) & arr1(i, 3)) = i
Next i
r_f = 1
For i = 1 To UBound(arr1)
  If d(arr1(i, 1) & arr1(i, 3)) < 0 Then
    Cells(r_f, 5) = arr1(i, 1)
    Cells(r_f, 6) = arr1(i, 2)
    Cells(r_f, 7) = arr1(i, 3)
    r_f = r_f + 1
  End If
Next i

MsgBox "完成！共保留：" & r_f - 2 & "筆資料。"
End Sub