返回列表 上一主題 發帖

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

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

本帖最後由 ssooi 於 2020-12-3 00:20 編輯

想要達到右邊表格的效果

AA.jpg
2020-12-3 00:10


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


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

本帖最後由 n7822123 於 2020-12-3 01:24 編輯

回復 1# ssooi

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

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

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

最後在用"資料剖析"功能,把剛剛 移除重複的H欄,用你剛剛設的分隔符號"-",重新拆成 兩欄(序號與牌子)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 luhpro 於 2020-12-3 04:55 編輯
如圖片所示,我想達到右邊表格的效果
(紅色是我故意標的,表示那是該序號內唯一的值)
不同序號要做區 ...
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
複製代碼

保留沒有重複的欄位-Q1.zip (14.16 KB)

TOP

回復  ssooi

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

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



這位大大~~不好意思~小弟已附上檔案
TEST.zip (6.33 KB)
我照大大的方式做了一次
不過不是我想要的方式~不曉得是不是我方法做錯

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

TOP

本帖最後由 n7822123 於 2020-12-3 11:43 編輯

回復 4# ssooi

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

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

我大概知道你的意思了......只要重複的都刪除,不是保留唯一值
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

回復 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)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

回復 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

TOP

本帖最後由 luhpro 於 2020-12-3 20:41 編輯
回復  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
複製代碼
效果應該是相同的,
上述僅供參考...

TOP

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

TOP

回復 8# luhpro


    了解,感謝指導

TOP

        靜思自在 : 有心就有福,有願就有力,自造福田,自得福緣。
返回列表 上一主題