同一發票號碼列出所有訂單編號(列在同一儲存格)

　暱稱: 厚臉皮的學生

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

12^#

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

回復 11# 准提部林

謝謝前輩
一年多了,現在才大概看懂
執行結果:

Option Explicit
Sub test_02()
Dim i&, N&, R&, T$, T2$, C%, Cx%, Arr, Brr, xD
'↑宣告變數(i,N,R)是長整數變數,(T,T2)是字串變數,(C,Cx)是短整數變數,
'其它是通用型變數
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD是字典
Arr = Range([a1], [b65536].End(3))
'↑令Arr是二維陣列!以[A1]到B欄最後一個有內容儲存格,這範圍儲存格值帶入
ReDim Brr(1 To UBound(Arr), 1 To 200)
'↑宣告Brr陣列範圍!縱向從1到Arr陣列最大索引列號,橫向從1到200
For i = 2 To UBound(Arr)
'↑設順迴圈!i從2到 Arr陣列最大索引列號
T = Arr(i, 1)
'↑令T這字串變數是 i迴圈列1欄Arr陣列值
T2 = Arr(i, 2)
'↑令T2這字串變數是 i迴圈列2欄Arr陣列值
If T = "" Or T2 = "" Then GoTo 99
'↑如果T字串變數是空字元或  如果T2字串變數是空字元,就跳到99位置繼續執行
R = xD(T)
'↑令R這長整數變數是以T字串變數查xD字典回傳的item值  (PS:若查不到!R初始值是 0)
C = xD(T & "/c")
'↑令C這短整數變數是以T字串變數連接"/c"的新字串,查xD字典回傳的item值
'(PS:若查不到!C初始值是 0)
If R = 0 Then
'↑如果R變數是 0 ??
   N = N + 1
   '↑令N這長整數變數是自身值 +1  (PS:N初始值是 0)
   R = N + 1
   '↑令R變數是 N變數 +1
   xD(T) = R
   '↑令以T變數當key,item是 R變數,放回字典
   Brr(R, 1) = Arr(i, 1)
   '↑令變數列1欄Brr陣列值是 i迴圈列1欄Arr陣列值
End If
C = C + 1
'↑令C變數是自身值 +1
xD(T & "/c") = C
'↑令以T變數連接"/c"的新字串當key,item是 C變數,放入字典
Brr(R, C + 1) = T2
'↑令R變數列(C1變數+1)欄Brr陣列值是 T2字串變數
If C > Cx Then Cx = C: Brr(1, Cx + 1) = "訂單(" & Cx & ")"
'↑如果C變數 > Cx這短整數變數,就令Cx變數是 C變數,
'1列(Cx變數+1)欄Brr陣列值是 "訂單(" 連接 Cx變數再連接 ")" 組成的新字串
99: Next i
Brr(1, 1) = "發票號碼"
Range("g1").Resize(N + 1, Cx + 1) = Brr
'[G1]儲存格擴展向下(N變數+1)列,向右擴展(Cx變數+1)欄,這範圍儲存格值以Brr陣列值帶入
End Sub

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

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

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

11^#

發表於 2021-10-17 10:54 | 只看該作者

多欄式:
Sub test_02()
Dim Arr, Brr, xD, i&, T$, T2$, R&, C%, Cx%, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([a1], [b65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 200)
For i = 2 To UBound(Arr)
T = Arr(i, 1): T2 = Arr(i, 2)
If T = "" Or T2 = "" Then GoTo 99
R = xD(T): C = xD(T & "/c")
If R = 0 Then N = N + 1: R = N + 1: xD(T) = R: Brr(R, 1) = Arr(i, 1)
C = C + 1: xD(T & "/c") = C: Brr(R, C + 1) = T2
If C > Cx Then Cx = C: Brr(1, Cx + 1) = "訂單(" & Cx & ")"
99: Next i
Brr(1, 1) = "發票號碼"
Range("g1").Resize(N + 1, Cx + 1) = Brr
End Sub

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

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

10^#

發表於 2021-10-17 10:53 | 只看該作者

兩欄式:
Sub test_01()
Dim Arr, xD, i&, T$, T2$, R&, N&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([a1], [b65536].End(3))
For i = 2 To UBound(Arr)
T = Arr(i, 1): T2 = Arr(i, 2): R = xD(T)
If T = "" Or T2 = "" Then GoTo 99
If R > 0 Then Arr(R, 2) = Arr(R, 2) & "、" & T2: GoTo 99
N = N + 1: R = N + 1: xD(T) = R
Arr(R, 1) = Arr(i, 1): Arr(R, 2) = T2
99: Next i
Range("d1").Resize(N + 1, 2) = Arr
End Sub

　暱稱: 厚臉皮的學生

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

9^#

發表於 2021-10-14 16:47 | 只看該作者

回復 8# samwang

謝謝指導!
如果列數多!您的執行的時間比我會的方式快很多!
謝謝前輩指導! xD(k)(C - 2)

Sub test2_1()
Dim Arr, Brr(), xD, T$, k, MA%, R%, C%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([a1], [b65536].End(3))
For i = 2 To UBound(Arr)
T = Arr(i, 1): If T = "" Then GoTo 99
xD(T) = xD(T) + 1
99: Next i
MA = WorksheetFunction.Max(xD.Items)
ReDim Brr(0 To xD.Count, 1 To MA + 1)
i = 0
For Each k In xD.keys
Brr(i, 1) = k
R = 2
For C = 2 To UBound(Arr)
   If Arr(C, 1) = Brr(i, 1) Then
      Brr(i, R) = Arr(C, 2)
      R = R + 1
   End If
Next
i = i + 1
Next
Range("g2").Resize(xD.Count, MA + 1) = Brr
End Sub

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-8-22

8^#

發表於 2021-10-14 14:07 | 只看該作者

回復 samwang

謝謝指導
再請教
如果發票號碼對應的客戶訂單不要用、符號個開放同一儲存格,
...
Andy2483 發表於 2021-10-14 12:35

Sub test2()
Dim Arr, Brr(), xD, T$, k, TC%, TC1%, R%, C%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([a1], [b65536].End(3))
For i = 2 To UBound(Arr)
T = Arr(i, 1): If T = "" Then GoTo 99
If xD.Exists(T) Then
      xD(T) = xD(T) & "、" & Arr(i, 2)
Else
      xD(T) = Arr(i, 2)
End If
99: Next i
ReDim Brr(1 To xD.Count, 1 To UBound(Arr))
R = 1
For Each k In xD.keys
xD(k) = Split(xD(k), "、")
TC = UBound(xD(k)) + 2
If TC > TC1 Then TC1 = TC
Brr(R, 1) = k
For C = 2 To UBound(xD(k)) + 2
      Brr(R, C) = xD(k)(C - 2)
Next
R = R + 1
Next
Range("g2").Resize(R - 1, TC1) = Brr
End Sub

　暱稱: 厚臉皮的學生

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

7^#

發表於 2021-10-14 12:35 | 只看該作者

回復 6# samwang

謝謝指導
再請教
如果發票號碼對應的客戶訂單不要用、符號個開放同一儲存格,
而是分開放在右側的儲存格接下去放!要怎麼改?

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-8-22

6^#

發表於 2021-10-14 12:27 | 只看該作者

回復 samwang

請教前輩字典只能1個key對應item? 可以1個對多個嗎?
Andy2483 發表於 2021-10-14 12:00

key可以很多個，但是每個key 是唯一，且對應的item可以很多個，謝謝。

　暱稱: 厚臉皮的學生

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

5^#

發表於 2021-10-14 12:00 | 只看該作者

回復 4# samwang

請教前輩字典只能1個key對應item? 可以1個對多個嗎?

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2025-8-22

4^#

發表於 2021-10-13 18:01 | 只看該作者

回復 1# leiru
請測試看看，謝謝
Sub test()
Dim Arr, xD, i&, T$
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([a1], [b65536].End(3))
For i = 2 To UBound(Arr)
T = Arr(i, 1): If T = "" Then GoTo 99
If xD.Exists(T) Then
xD(T) = xD(T) & "、" & Arr(i, 2)
Else
xD(T) = Arr(i, 2)
End If
99: Next i
Range("d2").Resize(xD.Count, 1) = Application.Transpose(xD.keys)
Range("e2").Resize(xD.Count, 1) = Application.Transpose(xD.Items)
End Sub