關於A欄是否可以判斷相同序號後將B欄合併並保留原始數據
想請問各位前輩，有在版上爬文並且有使用ChatGPT，但是結果都與預期的相差甚遠想看是否有函數或語法可以解決這個問題，原始檔案及語法請參閱附件(請參閱分頁-測試區)，謝謝!
問題點如下
A欄是否可判斷相同值向下填滿(請參閱檔案分頁-需求說明1)
判斷A欄若序號相同值將B欄保留原值合併並自動換列，A欄重複值刪除。(請參閱檔案分頁-需求說明2)
麻煩各位前輩指導，看是否有機會可改進目前人工逐筆去作業的方式，後續若完成會將檔案分享上來，感謝!! [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121133&ptid=23979]1#[/url] [i]killer77107[/i] [/b]
謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,學習方案如下,請前輩參考
執行前:
[attach]36281[/attach]
執行結果:
[attach]36282[/attach]
Option Explicit
Sub TEST()
Dim Brr, Y, i&, T$, P$, xR As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = [需求說明1!A1].CurrentRegion: Brr = xR
For i = 2 To UBound(Brr)
P = Brr(i, 1)
T = Switch((T <> P) * (P <> ""), P, P = "", T)
If T = "" Then GoTo i01
Y(T) = Replace(Trim(Y(T) & " " & Brr(i, 2)), " ", vbLf)
i01: Next
[J1] = "=A1": [K1] = "=B1"
[J2].Resize(Y.Count, 1) = Application.Transpose(Y.keys)
[K2].Resize(Y.Count, 1) = Application.Transpose(Y.items)
Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub 謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,練習不使用keys轉置結果,而以結果資料覆蓋原陣列資料,再將結果寫入儲存格,學習方案如下,請各位前輩指教
Option Explicit
Sub TEST_1()
Dim Brr, Y, i&, R&, T$, P$, xR As Range
Set Y = CreateObject("Scripting.Dictionary")
Set xR = [需求說明1!A1].CurrentRegion: Brr = xR
For i = 2 To UBound(Brr)
P = Brr(i, 1)
T = Switch((T <> P) * (P <> ""), P, P = "", T)
If T = "" Then GoTo i01
If Y(T) = "" Then
Y(T) = Y.Count + 1: Brr(Y(T), 1) = T: Brr(Y(T), 2) = Brr(i, 2): GoTo i01
End If
R = Y(T): Brr(R, 2) = Replace(Trim(Brr(R, 2) & " " & Brr(i, 2)), " ", vbLf)
i01: Next
[J1].Resize(Y.Count + 1, 2) = Brr
Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub 是想要兩種需求??
需求1) 填滿序號??
需求2) 合併相同序號的B欄內容??
若是要直接達到合併效果, 原表是哪一個??? 感謝andy2483前輩，下班回去研究
準提部林大大您好，是的 是想要兩種需求，原表是分頁需求說明1 AB兩欄資料
希望可以執行結果變成分頁需求說明2 右側的格式，感謝前輩不吝指導，謝謝！ [i=s] 本帖最後由 准提部林 於 2023-5-4 16:17 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121148&ptid=23979]5#[/url] [i]killer77107[/i] [/b]
這哪是兩種需求
是直接將表一...序號不連續(空白--視為上一個序號同組), 變成合併的表吧!(一個序號一行, B欄合併+換列)
需求1>>直接產生合併
Sub 合併_01()
Dim Arr, i&, N&
Arr = Range([a1], [b65536].End(3))
For i = 2 To UBound(Arr)
If Arr(i, 1) <> "" Then
N = N + 1
Arr(N + 1, 1) = Arr(i, 1)
Arr(N + 1, 2) = Arr(i, 2)
Else
Arr(N + 1, 2) = Arr(N + 1, 2) & Chr(10) & Arr(i, 2)
End If
Next i
[e:f].ClearContents
[e1:f1].Resize(N + 1, 2) = Arr
End Sub [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121154&ptid=23979]6#[/url] [i]准提部林[/i] [/b]
謝謝前輩指導不用字典的方法 回復 6# 准提部林
抱歉 可能是我對語法還不夠了解
原先以為要拆兩段才可以做，沒想到前輩的語法完全可以直接解決我的問題
感謝!! 我在好好了解一下!!
回復7#Andy2483 感謝前輩您提供的方式，一併學習 謝謝!! [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121154&ptid=23979]6#[/url] [i]准提部林[/i] [/b]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=121169&ptid=23979]8#[/url] [i]killer77107[/i] [/b]
謝謝兩位前輩
後學藉此帖學習 准提部林前輩的方案,學習心得註解如下,請前輩指教
Option Explicit
Sub 合併_01()
Dim Arr, i&, N&
[color=SeaGreen]'↑宣告變數[/color]
Arr = Range([a1], [b65536].End(3))
[color=SeaGreen]'↑令Arr是二維陣列,以儲存格值帶入陣列裡[/color]
For i = 2 To UBound(Arr)
[color=SeaGreen]'↑設順迴圈[/color]
If Arr(i, 1) <> "" Then
[color=SeaGreen] '↑如果序號不是空白?[/color]
N = N + 1
[color=SeaGreen] '↑令N變數累加1[/color]
Arr(N + 1, 1) = Arr(i, 1)
[color=SeaGreen] '↑令序號值帶入Arr陣列第1欄指定的索引列號位置[/color]
Arr(N + 1, 2) = Arr(i, 2)
[color=SeaGreen] '↑令材料值帶入Arr陣列第2欄指定的索引列號位置[/color]
Else
[color=SeaGreen] '↑否則[/color]
Arr(N + 1, 2) = Arr(N + 1, 2) & Chr(10) & Arr(i, 2)
[color=SeaGreen] '↑令材料值 帶入Arr陣列第2欄指定的索引列號位置值跳行的後面[/color]
End If
Next i
[e:f].ClearContents
[color=SeaGreen]'↑令清除舊結果欄內容[/color]
[e1:f1].Resize(N + 1, 2) = Arr
[color=SeaGreen]'↑令局部的Arr陣列值帶入儲存格中[/color]
End Sub
頁:
[1]