12
返回列表 上一主題 發帖

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

ssooi

帖子
37 
主題
15 
精華
0 
積分
72 
點名
0  
作業系統
win10 
軟體版本
0 
閱讀權限
20 
註冊時間
2020-7-23 
最後登錄
2022-5-27 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2020-12-3 00:17 | 只看該作者

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

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



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


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

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
2#
發表於 2020-12-3 01:22 | 只看該作者
本帖最後由 n7822123 於 2020-12-3 01:24 編輯

回復 1# ssooi

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

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

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

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

TOP

luhpro

帖子
835 
主題
6 
精華
0 
積分
915 
點名
1  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2025-7-5 
3#
發表於 2020-12-3 04:46 | 只看該作者
本帖最後由 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

帖子
37 
主題
15 
精華
0 
積分
72 
點名
0  
作業系統
win10 
軟體版本
0 
閱讀權限
20 
註冊時間
2020-7-23 
最後登錄
2022-5-27 
4#
發表於 2020-12-3 10:05 | 只看該作者
回復  ssooi

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

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



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

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

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
5#
發表於 2020-12-3 11:38 | 只看該作者
本帖最後由 n7822123 於 2020-12-3 11:43 編輯

回復 4# ssooi

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

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

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

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
6#
發表於 2020-12-3 12:07 | 只看該作者
回復 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

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2025-8-22 
7#
發表於 2020-12-3 13:55 | 只看該作者
回復 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

帖子
835 
主題
6 
精華
0 
積分
915 
點名
1  
作業系統
Win 10,7 
軟體版本
2019,2013,2003 
閱讀權限
50 
性別
男 
註冊時間
2010-5-3 
最後登錄
2025-7-5 
8#
發表於 2020-12-3 20:35 | 只看該作者
本帖最後由 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

ssooi

帖子
37 
主題
15 
精華
0 
積分
72 
點名
0  
作業系統
win10 
軟體版本
0 
閱讀權限
20 
註冊時間
2020-7-23 
最後登錄
2022-5-27 
9#
發表於 2020-12-3 20:54 | 只看該作者
謝謝大家
太感動了
luhpro 大大的程式我一開始就有試過
是完全沒問題的
只是他的程式太難~我無法消化
哈哈
再次感謝大家

TOP

samwang

帖子
976 
主題
7 
精華
0 
積分
1018 
點名
0  
作業系統
Win10 
軟體版本
Office 2016 
閱讀權限
50 
性別
男 
註冊時間
2013-4-19 
最後登錄
2025-8-22 
10#
發表於 2020-12-3 20:59 | 只看該作者
回復 8# luhpro


    了解，感謝指導

TOP

        靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。
12
返回列表 上一主題