麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 保留沒有重複的欄位 [打印本頁]

作者: ssooi 時間: 2020-12-3 00:17 標題: 保留沒有重複的欄位

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

[attach]32743[/attach]

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

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

作者: n7822123 時間: 2020-12-3 01:22

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

回復 1# ssooi

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

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

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

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

作者: luhpro 時間: 2020-12-3 04:46

本帖最後由 luhpro 於 2020-12-3 04:55 編輯

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

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

Sub aa()
Dim iI%
Dim lRow&
Dim sStr$
Dim vD1, vD2, vA
lRow = Cells(Rows.Count, 5).End(xlUp).Row
If lRow < 2 Then lRow = 2
Range([E2], Cells(lRow, 7)).Clear ' 清舊資料
Set vD1 = CreateObject("Scripting.Dictionary") ' 放重複次數
Set vD2 = CreateObject("Scripting.Dictionary") ' 放資料列號
lRow = 2
Do While Cells(lRow, 1) <> ""
sStr = Cells(lRow, 1) & "_" & Cells(lRow, 3) ' "_" 資料區隔符號,可改成資料中不會出現的特定字元
If IsEmpty(vD1(sStr)) Then
vD1(sStr) = 1
vD2(sStr) = lRow
Else
vD1(sStr) = vD1(sStr) + 1
End If
lRow = lRow + 1
Loop
lRow = 2
For Each vA In vD1.keys
If vD1(vA) = 1 Then ' 重複次數為1的才列出來
For iI = 1 To 3
Cells(lRow, 4 + iI) = Cells(vD2(vA), iI)
Next
lRow = lRow + 1
End If
Next
End Sub

複製代碼

作者: ssooi 時間: 2020-12-3 10:05

回復 ssooi

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

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

這位大大~~不好意思~小弟已附上檔案
[attach]32748[/attach]
我照大大的方式做了一次
不過不是我想要的方式~不曉得是不是我方法做錯

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

作者: n7822123 時間: 2020-12-3 11:38

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

回復 4# ssooi

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

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

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

作者: n7822123 時間: 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

檔案如下

[attach]32749[/attach]

作者: samwang 時間: 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

作者: luhpro 時間: 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)
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
複製代碼
...
samwang 發表於 2020-12-3 13:55

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

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

複製代碼

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

作者: ssooi 時間: 2020-12-3 20:54

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

作者: samwang 時間: 2020-12-3 20:59

回復 8# luhpro

了解，感謝指導

作者: luhpro 時間: 2020-12-3 22:08

謝謝大家
太感動了
luhpro 大大的程式我一開始就有試過
是完全沒問題的
只是他的程式太難~我無法消化
...
ssooi 發表於 2020-12-3 20:54

太難......　O.O
我(業餘者)的程式大都是陽春型的,
很少牽扯到簡化程式碼的部分呢.

要了解程式怎麼跑的,
有個滿不錯的功能：檢視->區域變數視窗,
善用單步模式(F8)
並把左邊有+的都點一下打開觀察每個指令對其成員及內含值的變化,
再搭配底下即時運算視窗用 ?變數名來取值做確認.

Dictionary 不是太難的東西,
它有兩個部分 Item 與 key
Item=vD(key) ' 內含值 = vD(鍵值)

Cells 則是儲存格的表示形式之一,
Range("B5")=Cells(5, 2) ' Range("儲存格位址")=Cells(列號, 欄號)

IsEmpty 函數則是檢查括弧內的值是否為空,
希望對你有所幫助.

作者: hcm19522 時間: 2020-12-4 10:43

https://blog.xuite.net/hcm19522/twblog/589493905

作者: 准提部林 時間: 2020-12-4 17:23

回復 8# luhpro

我習慣用 GOTO , 它可簡化或減少些判斷,
例如:
IF A=1 AND B=2 AND C=3 THEN
執行動作
END IF
依常理, 它要同時判斷3個, 都符合了才執行,

若分開判斷
IF A<>1 THEN GOTO 100 '這條件成立, 跳至下個迴圈, 而不須再進行B及C的判斷
IF B<>2 THEN GOTO 100
IF C<>3 THEN GOTO 100

當然也可用OR
IF A<>1 OR B<>2 OR C<>3 THEN GOTO 100
但這不確定是否要ABC都判斷完了才跳出

程式寫法, 大家都會養成個人習慣, 只要不影響程式運行效率, 大都能接受吧!!!

作者: luhpro 時間: 2020-12-5 07:01

回復 luhpro

我習慣用 GOTO , 它可簡化或減少些判斷,
例如:
IF A=1 AND B=2 AND C=3 THEN
執行 ...
准提部林發表於 2020-12-4 17:23

以你所舉的例子在結構化程式會是這樣的形式:
  For ...
If A<>1 Then  '這條件成立, 跳至下個迴圈, 而不須再進行B及C的判斷
   If B<>2 Then
      If C<>3 Then
      ......
   End If
   End If
End If
...
  Next

程式寫法, 大家都會養成個人習慣, 只要不影響程式運行效率, 大都能接受吧!!!

嗯......
是的, 使用適合自己的方式就可以了.

作者: n7822123 時間: 2020-12-5 15:55

本帖最後由 n7822123 於 2020-12-5 16:04 編輯

回復 14# luhpro

如果VBA能有 VB.Net的 Continue [For | Do] 語法，一般人可能也不會用到Goto

其實我認為Goto才是最基本的語法，有學過組合語言的人都知道，很多組合語言都沒有For、Do 迴圈

都是利用標籤跳行執行，來達成迴圈功能，我利用VBA語法來模擬組合語言寫For 、 Do迴圈的邏輯

如下程式參考

Sub ADD100Sum()
'計算1加到100的累加值
I = 0
N = 100
迴圈:
I = I + 1
S = S + I
If I < N Then GoTo 迴圈
MsgBox "1加到" & N & "的總合= " & S
End Sub

Sub ADDTo30000up()
'計算1加到N的累加值，直到超過30000
'回傳N值
I = 0
Target = 30000
迴圈:
I = I + 1
S = S + I
If S < Target Then GoTo 迴圈
MsgBox "1加到'" & I & "'的累加值=" & S & "，剛過30000 "
End Sub

作者: luhpro 時間: 2020-12-8 01:54

本帖最後由 luhpro 於 2020-12-8 01:58 編輯

回復 15# n7822123
一般經歷過5.25"磁碟片的人應該也都知道組合語言吧.(總覺得那些遊戲程式又小又超好玩的)
還記得那時侯瘋狂的買組合語言和Basic的書邊看邊學,(一台PC要7萬多,那時還看不到中文呢)
但我也只能算是解析過知道位元移位是甚麼概念罷了,
真要說程式設計還是有很多要學的，
這網站上可挖的寶太多了,學不完阿......

Goto 當然是最早期的基本指令.
它的應用彈性與範圍非常大,
卻也容易因為非預期運算子帶入邏輯條件而走入誤區,
所以後來高階語言才會設計出專有的迴圈指令.

像我一般都是先打好外圍成對指令再在裡面加指令, 即:
先打 Do ... While 或是 For...Next 亦或是 With...End With等,
再在中間加上指令,
好處是作用範圍不會錯,
也不會發生對應不到或不小心交錯成對指令(例 : For ... For... Next... Next)的情形.

結構化程式是較易解析判讀對想學習的人也較適合.
當然,各種方式與指令只要能善用都是很好的.

你的例子用 Do...Loop Until 迴圈就可以完成的喔:

Do
I = I + 1
S = S + I
Loop Until Not (I < N)

複製代碼

當然, While...Wend 迴圈也是沒問題的:

While I < N
I = I + 1
S = S + I
Wend

複製代碼

作者: ssooi 時間: 2020-12-9 21:32

謝謝各位前輩
學習到非常多
謝謝

作者: Andy2483 時間: 2023-12-1 13:57

本帖最後由 Andy2483 於 2023-12-1 18:56 編輯

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教
執行前:
[attach]37095[/attach]

執行結果:
[attach]37096[/attach]

Option Explicit
Sub TEST()
Dim Brr, Z, A, i&, j%, R&, Y&, T$
'↑宣告變數
Set Z = CreateObject("Scripting.Dictionary")
'↑令Z變數是字典
Brr = Range([C1], [A65536].End(3))
'↑令Brr變數是裝入儲存格值的二維陣列
For i = 2 To UBound(Brr)
'↑設順迴圈!從2到Brr陣列最大索引列號
T = Brr(i, 1) & "|" & Brr(i, 3)
'↑令T變數是第1欄與第3欄陣列值以 "|"符號串接的新字串
Z(T) = Z(T) + 1: Z(T & "/r") = i
'↑令T變數為key的item值累加1(這是要記錄字串組出現過幾次)
'↑令T變數連接"/r" 的新字串為key,item是索引列號,納入Z字典中
Next
For Each A In Z.Keys
'↑設逐項迴圈!令A是Z字典裡的Keys之一
If Right(A, 2) = "/r" Or Z(A) > 1 Then GoTo A01
'↑如果是記錄列號或字串組出現過次大於1 的都跳過
R = R + 1: Y = Z(A & "/r")
'↑令R變數累加1 (這是要讓符合條件的資料放置的列號)
For j = 1 To 3: Brr(R, j) = Brr(Y, j): Next
'↑令符合條件的資料寫入指定的陣列位置
A01: Next
If R = 0 Then Exit Sub Else [J:L].ClearContents
'↑如果沒有符合條件的資料!就結束程式執行,否則清除舊的結果格內容
[J2].Resize(R, 3) = Brr
'↑令擴展的儲存格區域以Brr陣列值寫入,超過該範圍的陣列值忽略
[J1:L1] = [A1:C1].Value
'↑令新標題位置格值等於原標題值
End Sub

作者: singo1232001 時間: 2023-12-2 02:49

回復 1# ssooi

兩種寫法自己挑一個
Sub t1()
o = Split("Provider=Microsoft.,,.0;Extended Properties=Excel ,,.0;Data Source=" & ThisWorkbook.FullName, ",")
Set cn = CreateObject("adodb.connection"): If Application.Version > 12 Then o(1) = "ACE.OLEDB.12": _
o(3) = 12: cn.Open Join(o, "") Else o(1) = "Jet.OLEDB.4": o(3) = 8: cn.Open Join(o, "")
q = "SELECT a.序號, a.時程, a.牌子 FROM [工作表2$A1:C] as a "
q = q & "WHERE EXISTS ( SELECT 1 FROM [工作表2$A1:C] AS b "
q = q & "             WHERE b.序號 = a.序號 AND b.牌子 = a.牌子 "
q = q & "             GROUP BY b.序號, b.牌子 HAVING COUNT(*) = 1)"
[G:J].ClearContents: [G1].CopyFromRecordset cn.Execute(q)
End Sub

Sub t2()
o = Split("Provider=Microsoft.,,.0;Extended Properties=Excel ,,.0;Data Source=" & ThisWorkbook.FullName, ",")
Set cn = CreateObject("adodb.connection"): If Application.Version > 12 Then o(1) = "ACE.OLEDB.12": _
o(3) = 12: cn.Open Join(o, "") Else o(1) = "Jet.OLEDB.4": o(3) = 8: cn.Open Join(o, "")
q = "SELECT a.序號, a.時程, a.牌子 FROM [工作表2$A1:C] AS a "
q = q & "WHERE ( SELECT COUNT(*) FROM [工作表2$A1:C] AS b "
q = q & "       WHERE b.序號 = a.序號 AND b.牌子 = a.牌子) = 1"
[G:J].ClearContents: [G1].CopyFromRecordset cn.Execute(q)
End Sub

作者: singo1232001 時間: 2023-12-2 07:46

本帖最後由 singo1232001 於 2023-12-2 07:56 編輯

回復 19# singo1232001

Sub t5()
I = Split("Provider=Microsoft.,Jet.OLEDB.4,.0;Extended Properties=Excel ,8,.0;Data Source=", ",")
If Application.Version > 12 Then I(1) = "ACE.OLEDB.12": I(3) = 12
Set cn = CreateObject("adodb.connection"): cn.Open Join(I, "") & ThisWorkbook.FullName
q = "SELECT a.序號, a.時程, a.牌子 FROM [工作表2$A1:C] AS a WHERE ( SELECT COUNT(*) "
q = q & "FROM [工作表2$A1:C] AS b WHERE b.序號 = a.序號 AND b.牌子 = a.牌子) = 1"
[G:J].ClearContents: [G1].CopyFromRecordset cn.Execute(q)
End Sub

我覺得前三行的方式應該是adodb.connection 呼叫最簡短的一種寫法了

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)