[發問] 關於A欄是否可以判斷相同序號後將B欄合併並保留原始數據

killer77107

想請問各位前輩，有在版上爬文並且有使用ChatGPT，但是結果都與預期的相差甚遠
想看是否有函數或語法可以解決這個問題，原始檔案及語法請參閱附件(請參閱分頁-測試區)，謝謝!
問題點如下
A欄是否可判斷相同值向下填滿(請參閱檔案分頁-需求說明1)
判斷A欄若序號相同值將B欄保留原值合併並自動換列，A欄重複值刪除。(請參閱檔案分頁-需求說明2)

麻煩各位前輩指導，看是否有機會可改進目前人工逐筆去作業的方式，後續若完成會將檔案分享上來，感謝!!

Andy2483

回復 1# killer77107


    謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,學習方案如下,請前輩參考

執行前:

下載 (131.73 KB)

2023-5-4 09:45

執行結果:

下載 (150.8 KB)

2023-5-4 09:46

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

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,練習不使用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欄內容??

若是要直接達到合併效果, 原表是哪一個???

killer77107

感謝andy2483前輩，下班回去研究
準提部林大大您好，是的 是想要兩種需求，原表是分頁需求說明1 AB兩欄資料
希望可以執行結果變成分頁需求說明2 右側的格式，感謝前輩不吝指導，謝謝！

准提部林

回復 5# killer77107


這哪是兩種需求
是直接將表一...序號不連續(空白--視為上一個序號同組), 變成合併的表吧!(一個序號一行, 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

Andy2483

回復 6# 准提部林


    謝謝前輩指導不用字典的方法

killer77107

回復 6# 准提部林
抱歉 可能是我對語法還不夠了解
原先以為要拆兩段才可以做，沒想到前輩的語法完全可以直接解決我的問題
感謝!! 我在好好了解一下!!

回復7#Andy2483 感謝前輩您提供的方式，一併學習 謝謝!!

Andy2483

回復 6# 准提部林
回復 8# killer77107


    謝謝兩位前輩
後學藉此帖學習 准提部林前輩的方案,學習心得註解如下,請前輩指教

Option Explicit
Sub 合併_01()
Dim Arr, i&, N&
'↑宣告變數
Arr = Range([a1], [b65536].End(3))
'↑令Arr是二維陣列,以儲存格值帶入陣列裡
For i = 2 To UBound(Arr)
'↑設順迴圈
    If Arr(i, 1) <> "" Then
    '↑如果序號不是空白?
       N = N + 1
       '↑令N變數累加1
       Arr(N + 1, 1) = Arr(i, 1)
       '↑令序號值帶入Arr陣列第1欄指定的索引列號位置
       Arr(N + 1, 2) = Arr(i, 2)
       '↑令材料值帶入Arr陣列第2欄指定的索引列號位置
    Else
    '↑否則
       Arr(N + 1, 2) = Arr(N + 1, 2) & Chr(10) & Arr(i, 2)
       '↑令材料值 帶入Arr陣列第2欄指定的索引列號位置值跳行的後面
    End If
Next i
[e:f].ClearContents
'↑令清除舊結果欄內容
[e1:f1].Resize(N + 1, 2) = Arr
'↑令局部的Arr陣列值帶入儲存格中
End Sub