[發問] 保留沒有重複的欄位

ssooi

下載 (35.03 KB)
想要達到右邊表格的效果

2020-12-3 00:10

如圖片所示，我想達到右邊表格的效果
(紅色是我故意標的，表示那是該序號內唯一的值)
不同序號要做區別
個別「序號」內有重複的「牌子」
該列就刪除
個別「序號」內不保留有重複的「牌子」


我試過RemoveDuplicates，但是他會將有重複的刪除，然後保留一個「牌子」
想了蠻多方法，但是就卡在序號依序下來(有好幾百個序號)，然後是在同個工作表，
實在想不出方式了
麻煩各位先進
感激不盡!!!!!!!

n7822123

回復 1# ssooi

沒測試檔案，不想寫VBA~提供一個方法給你

隨便找一個欄位(H)把序號 跟 牌子 用隨便一個分隔符號 串接起來 Ex  H1： =A1 & "-" & C1

再去掉公式轉成值(複製>選擇性貼上>值)，然後用Excel的 "移除重複"功能，針對剛剛串接的H欄位做移除重複

最後在用"資料剖析"功能，把剛剛 移除重複的H欄，用你剛剛設的分隔符號"-"，重新拆成 兩欄(序號與牌子)

luhpro

如圖片所示，我想達到右邊表格的效果
(紅色是我故意標的，表示那是該序號內唯一的值)
不同序號要做區 ...
ssooi 發表於 2020-12-3 00:17

要篩選列出沒有重複(反之亦可)的資料,
使用Dictionary函數就可以了:

1. Sub aa()
   
2.   Dim iI%
   
3.   Dim lRow&
   
4.   Dim sStr$
   
5.   Dim vD1, vD2, vA
   
6.   
   
7.   lRow = Cells(Rows.Count, 5).End(xlUp).Row
   
8.   If lRow < 2 Then lRow = 2
   
9.   Range([E2], Cells(lRow, 7)).Clear ' 清舊資料
   
10.   Set vD1 = CreateObject("Scripting.Dictionary") ' 放重複次數
    
11.   Set vD2 = CreateObject("Scripting.Dictionary") ' 放資料列號
    
12.   lRow = 2
    
13.   Do While Cells(lRow, 1) <> ""
    
14.     sStr = Cells(lRow, 1) & "_" & Cells(lRow, 3) ' "_" 資料區隔符號,可改成資料中不會出現的特定字元
    
15.     If IsEmpty(vD1(sStr)) Then
    
16.       vD1(sStr) = 1
    
17.       vD2(sStr) = lRow
    
18.     Else
    
19.       vD1(sStr) = vD1(sStr) + 1
    
20.     End If
    
21.     lRow = lRow + 1
    
22.   Loop
    
23.   
    
24.   lRow = 2
    
25.   For Each vA In vD1.keys
    
26.     If vD1(vA) = 1 Then ' 重複次數為1的才列出來
    
27.       For iI = 1 To 3
    
28.         Cells(lRow, 4 + iI) = Cells(vD2(vA), iI)
    
29.       Next
    
30.       lRow = lRow + 1
    
31.     End If
    
32.   Next
    
33. End Sub

複製代碼

ssooi

回復  ssooi

沒測試檔案，不想寫VBA~提供一個方法給你

隨便找一個欄位(H)把序號 跟 牌子 用隨便一個 ...
n7822123 發表於 2020-12-3 01:22

這位大大~~不好意思~小弟已附上檔案
TEST.zip (6.33 KB)

下載次數: 9

2020-12-3 10:05

我照大大的方式做了一次
不過不是我想要的方式~不曉得是不是我方法做錯

Excel的 "移除重複"功能
他會刪除其他重複項，保留一個值
我想要的是~~只要是重複的~~全部刪除
感激不盡
請問有其他方式嗎?
謝謝

n7822123

回復 4# ssooi

把序號跟牌子 串接起來，就不會只針對牌子移除重複

例如  1-T1  與 2-T1  會被視為不一樣的，不可能被移除重複

我大概知道你的意思了......只要重複的都刪除，不是保留唯一值

n7822123

回復 4# ssooi

luhpro 大大的程式應該可以用，我也用你的附件寫上程式

程式如下

Sub test1203()
Dim D As Object, Arr, R&, Key$
Set D = CreateObject("Scripting.Dictionary")
Arr = [A1].CurrentRegion
For R = 1 To UBound(Arr)
  Key = Arr(R, 1) & "-" & Arr(R, 3)
  If D.Exists(Key) Then D(Key) = "X" Else D(Key) = R
Next R
R = 0
For Each Item In D.Items
  If Item <> "X" Then
    R = R + 1
    Cells(R, "F").Resize(, 3) = Cells(Item, "A").Resize(, 3).Value
  End If
Next
End Sub

檔案如下

TEST-1203.rar (13.32 KB)

下載次數: 7

2020-12-3 12:06

samwang

回復 4# ssooi

我也覺得 luhpro 大大的程式應該可以用，所以我的程式如下，請在確認，謝謝。

Sub test()
Dim Arr, xD, N&, i&, j&, T$
Arr = Range([A1], [C65536].End(xlUp))
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
    T = Arr(i, 1) & "_" & Arr(i, 3)
    xD(T) = xD(T) + 1
Next
For i = 2 To UBound(Arr)
    T = Arr(i, 1) & "_" & Arr(i, 3)
    If xD(T) > 1 Then GoTo 100
    N = N + 1
    For j = 1 To 3: Arr(N + 1, j) = Arr(i, j): Next
100: Next
If N > 0 Then [E1].Resize(N + 1, 3) = Arr
End Sub

luhpro

回復  ssooi

...
For i = 2 To UBound(Arr)
    T = Arr(i, 1) & "_" & Arr(i, 3)

1.     If xD(T) > 1 Then GoTo 100
   
2.     N = N + 1
   
3.     For j = 1 To 3: Arr(N + 1, j) = Arr(i, j): Next
   
4. 100: Next

複製代碼

...
samwang 發表於 2020-12-3 13:55

以結構化程式的概念來說,
會建議儘量不要使用 Goto指令.
上述這段程式可以修改成: (單純轉換成等效指令, 並未驗證你的程式執行結果)

1.     If xD(T) = 1 Then
   
2.         N = N + 1
   
3.         For j = 1 To 3: Arr(N + 1, j) = Arr(i, j): Next
   
4.     End if
   
5. Next

複製代碼

效果應該是相同的,
上述僅供參考...

ssooi

謝謝大家
太感動了
luhpro 大大的程式我一開始就有試過
是完全沒問題的
只是他的程式太難~我無法消化
哈哈
再次感謝大家

samwang

回復 8# luhpro


    了解，感謝指導