帖子: 45
主題: 7
精華: 0
積分: 102
點名: 0
作業系統: WIN7
軟體版本: OFFICE 2016
閱讀權限: 20
註冊時間: 2019-4-27
最後登錄: 2024-11-23

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2020-10-10 20:13 | 只看該作者

[發問] 字串刪除重複

想將C欄重複的項目刪除，變成D欄的效果

程式目前功能是單條件多結果列出，並將列出資料以"，"隔開
Sub test1()
[料件!C2:C6000].ClearContents '清除C資料
Set xD = CreateObject("Scripting.Dictionary") '字典
Sheets("料件").Select '跳到
arr = Range([位置!A2], [位置!D65536].End(xlUp))
For i = 1 To UBound(arr)
xD(arr(i, 1)) = xD(arr(i, 1)) & "," & arr(i, 4)
Next i
Set xR = Range([A2], [A65536].End(xlUp))
For Each xT In xR
Cells(xT.Row, "C") = xD(xT.Value)
Next
Set xD = Nothing
End Sub

該如何修改程式呢?還是只能打掉重寫?

1010A.zip (17.6 KB)

樓主熱帖

軒云熊

中學生 Rank: 2

帖子: 254
主題: 6
精華: 0
積分: 310
點名: 0
作業系統: W10
軟體版本: Excel 2016
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2019-6-16
最後登錄: 2024-9-23

2^#

發表於 2020-10-11 01:21 | 只看該作者

回復 1# qaqa3296

有空再看看這樣可不可以

Sub test1()
Application.ScreenUpdating = False
[料件!C2:C6000].ClearContents '清除C資料
Set xD = CreateObject("Scripting.Dictionary") '字典
Sheets("料件").Select '跳到
arr = Range([位置!A2], [位置!D65536].End(xlUp))
Range(Sheets(2).Cells(2, 1).End(xlDown), Sheets(2).Cells(2, 4)).Sort Sheets(2).Cells(2, 4).End(xlDown)
For I = 1 To UBound(arr)
If I = UBound(arr) Then Exit For
If arr(I, 4) <> arr(I + 1, 4) Then
xD(arr(I, 1)) = xD(arr(I, 1)) & "," & arr(I, 4)
End If
Next I
Set xR = Range([A2], [A65536].End(xlUp))
For Each xT In xR
Cells(xT.Row, "C") = xD(xT.Value)
Next
Set xD = Nothing
Application.ScreenUpdating = True
End Sub

複製代碼

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-25

3^#

發表於 2020-10-11 09:48 | 只看該作者

本帖最後由准提部林於 2020-10-11 09:50 編輯

Sub TEST_A1()
Dim Arr, xD, i&, T1$, T2$, T3$
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([位置!A1], [位置!D65536].End(xlUp))
For i = 2 To UBound(Arr)
T1 = Arr(i, 1): T2 = Arr(i, 4)
If T1 = "" Or T2 = "" Then GoTo 101
T3 = T1 & "|" & T2: xD(T3) = xD(T3) + 1 '用兩個關鍵字組合, 排除重覆
If xD(T3) = 1 Then xD(T1) = xD(T1) & "," & T2 'xD(T3) = 1 為首次出現的, 加入字串中, 超過1, 略過
101: Next i
Arr = Range([料件!A1], [料件!A65536].End(xlUp))
For i = 2 To UBound(Arr)
Arr(i - 1, 1) = Mid(xD(Arr(i, 1) & ""), 2) '字串首字符為"逗號", 須用mid取第2個字以後的字元
Next i
[料件!C2].Resize(UBound(Arr) - 1) = Arr
End Sub

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-25

4^#

發表於 2020-10-11 09:58 | 只看該作者

Sub TEST_A2()
Dim Arr, xD, i&, T1$, T2$, T3$, xR As Range
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([位置!A1], [位置!D65536].End(xlUp))
For i = 2 To UBound(Arr)
T1 = Arr(i, 1): T2 = Arr(i, 4)
If T1 = "" Or T2 = "" Then GoTo 101
T3 = T1 & "|" & T2:  xD(T3) = xD(T3) + 1
If xD(T3) = 1 Then xD(T1) = xD(T1) & IIf(xD(T1) = "", "", ",") & T2  '用 iif 避免字串開頭出現"逗號"
101: Next i
For Each xR In Range([料件!A2], [料件!A65536].End(xlUp)) '直接在儲存格逐一填入, 速度慢
xR(1, 3) = xD(xR & "")  '注意:xD(xR & "") 中的"雙引號"不可省略, 或用xD(xR.Value)
Next
End Sub

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-25

5^#

發表於 2020-10-11 10:09 | 只看該作者

字典的key的型態須明確界定,
"數值"及"文字"格式, 會視為不同,
例如: xd(123) 及 xd("123") 視為不同,
所以最好用變數代替, 再做字典key,
dim T$ 或 dim T as string
T = 123
xd(T) 即等同 xd("123")

英文大小寫也視為不同,
例如: xd("ABC") 及 xd("Abc") 視為不同,
必要時可用ucase 或 lcase 統一大小寫, 再置入字典

TOP

hcm19522

大學生 Rank: 4

帖子: 1387
主題: 4
精華: 0
積分: 1397
點名: 0
作業系統: WIN
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2015-9-11
最後登錄: 2024-11-25

熱烈參與勳章

6^#

發表於 2020-10-11 10:20 | 只看該作者

https://blog.xuite.net/hcm195222/blog/589401247

google"EXCEL迷" blog 或google網址:https://hcm19522.blogspot.com/

TOP

軒云熊

中學生 Rank: 2

帖子: 254
主題: 6
精華: 0
積分: 310
點名: 0
作業系統: W10
軟體版本: Excel 2016
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2019-6-16
最後登錄: 2024-9-23

7^#

發表於 2020-10-11 11:08 | 只看該作者

謝謝准提大大和 hcm19522 大大的指導
用 .Sort 會出現奇怪的問題要點2次執行才會正常不知道為甚麼

TOP

qaqa3296

中學生 Rank: 2

帖子: 45
主題: 7
精華: 0
積分: 102
點名: 0
作業系統: WIN7
軟體版本: OFFICE 2016
閱讀權限: 20
註冊時間: 2019-4-27
最後登錄: 2024-11-23

8^#

發表於 2020-10-11 15:30 | 只看該作者

感謝軒云熊、准提部林和hcm19522的回復

有發現軒云熊程式點兩次才正常的問題，但也看不出為什麼

hcm19522提供的函數蠻有意思，我一開始也是用函數寫，結果資料跑了30分鐘，太久了才開始用VBA練習

感謝准提部林教的寫程式小技巧以及注意事項

有學到東西，受益良多

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

9^#

發表於 2023-5-16 16:14 | 只看該作者

回復 3# 准提部林

謝謝前輩
後學藉此帖學習前輩的方案稍作變化,方案學習心得至解如下,請前輩再指導

資料表:

結果表執行前:

執行結果:

Option Explicit
Sub TEST()
Dim Arr, xD, i&, T1$, T2$, T3$
'↑宣告變數
Set xD = CreateObject("Scripting.Dictionary")
'↑xD變數是字典
Arr = Range([位置!A1], [位置!D65536].End(xlUp))
'↑令Arr變數是二維陣列,以儲存格值帶入陣列中
For i = 2 To UBound(Arr)
'↑設順迴圈
T1 = Arr(i, 1): T2 = Arr(i, 4)
'↑令迴圈Arr陣列值以變數承裝,順道定義其值是字串
If T1 = "" Or T2 = "" Then GoTo i01
'↑如果品號或品名是空的,不執行!跳到 i01標示位置繼續執行
T3 = T1 & "|" & T2: xD(T3) = xD(T3) + 1
'↑令T3是以"|"間隔的組合字串,
'令T3變數當key,item是自身累加 1,納入xD字典
If xD(T3) = 1 Then xD(T1) = Trim(xD(T1) & " " & T2)
'↑如果T3變數是第1次納入字典(item值=1),
'就令T1變數當key,item是自身值連接T2變數,中間以空白字元隔開,
'最後再去除頭尾的空白字元
i01: Next i
Arr = Range([料件!A1], [料件!A65536].End(xlUp))
'↑令Arr變數是二維陣列,以儲存格值帶入陣列中
For i = 2 To UBound(Arr)
'↑設順迴圈
Arr(i - 1, 1) = Replace(xD(Arr(i, 1) & ""), " ", ",")
'↑令以迴圈Arr陣列值查xD字典得到item值,經置換空白字元為逗號,
'覆蓋掉原Arr陣列值
Next i
[料件!C2].Resize(UBound(Arr) - 1) = Arr
'↑令[料件!C2]擴展向下Arr陣列最大索引號-1個儲存格範圍值,
'以Arr陣列帶入,超過此範圍的陣列值被忽略
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP