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

標題: 出貨單建立 [打印本頁]

作者: cclo0728 時間: 2022-10-6 10:47 標題: 出貨單建立

請問各位先進，目前遇到此問題
我先在資料輸入打完資料後，將所有資料匯至出貨資料這區塊
想在出貨資料分頁將A欄也帶入單號
請問要如讓將單號這欄，可以自動判定B欄位這次新增多少"圖號"，''將單號複製在A欄位
[attach]35269[/attach]
[attach]35270[/attach]

作者: samwang 時間: 2022-10-6 16:12

回復 1# cclo0728
請測試看看，謝謝
Sub test()
Dim Arr, T, R&
With Sheets("資料輸入")
R = .[b65536].End(3).Row
If R < 5 Then Exit Sub
Arr = .Range("b5:g" & R)
T = .[F2]
End With
With Sheets("出貨資料")
R = .[b65536].End(3).Row + 1
.Range("b" & R).Resize(UBound(Arr), 6) = Arr
.Range("a" & R & ":a" & R + UBound(Arr) - 1) = T
End With
End Sub

作者: cclo0728 時間: 2022-10-6 16:36

回復 2# samwang
Sub test()
Dim Arr, T, R&
With Sheets("資料輸入")
R = .[b65536].End(3).Row
If R < 5 Then Exit Sub <------這行的意思是?
Arr = .Range("b5:g" & R)
T = .[F2]
End With
With Sheets("出貨資料")
R = .[b65536].End(3).Row + 1
.Range("b" & R).Resize(UBound(Arr), 6) = Arr<------這行的意思是?
.Range("a" & R & ":a" & R + UBound(Arr) - 1) = T<------這行的意思是?
End With
End Sub

假如我把客戶單號由f2移至b2
要將a2與b2這兩欄放到出貨資料ab欄請問要如何修改?

作者: samwang 時間: 2022-10-6 16:52

回復 samwang
Sub test()
Dim Arr, T, R&
With Sheets("資料輸入")
R = ..End(3).Row
If R ...
cclo0728 發表於 2022-10-6 16:36

If R < 5 Then Exit Sub <------這行的意思是? >> 如果沒資料就離開
.Range("b" & R).Resize(UBound(Arr), 6) = Arr<------這行的意思是? >> 資料貼到出貨資料的最後一列
.Range("a" & R & ":a" & R + UBound(Arr) - 1) = T<------這行的意思是? >> 貼上單號
假如我把客戶單號由f2移至b2 >> T = .[b2]
要將a2與b2這兩欄放到出貨資料ab欄請問要如何修改? >> 不好意思，看不太懂，請附上檔案

作者: cclo0728 時間: 2022-10-7 08:10

回復 4# samwang
要將資料輸入的a2與b2欄位，帶入出貨資料的分頁
[attach]35271[/attach]

作者: samwang 時間: 2022-10-7 08:30

回復 samwang
要將資料輸入的a2與b2欄位，帶入出貨資料的分頁
cclo0728 發表於 2022-10-7 08:10

請測試看看，謝謝
Sub test()
Dim Arr, T, T2, R&
With Sheets("資料輸入")
R = .[b65536].End(3).Row
If R < 5 Then Exit Sub
Arr = .Range("b5:g" & R)
T = .[A2]: T2 = .[B2]
End With
With Sheets("出貨資料")
R = .[C65536].End(3).Row + 1
.Range("C" & R).Resize(UBound(Arr), 6) = Arr
.Range("a" & R & ":a" & R + UBound(Arr) - 1) = T
.Range("b" & R & ":b" & R + UBound(Arr) - 1) = T2
End With
End Sub

作者: cclo0728 時間: 2022-10-7 09:48

回復 6# samwang
非常感謝，可以執行
昨天在看的時候以為可以直接a2:b2直接用範圍複製
今天知道要如何處理了，謝謝

作者: Andy2483 時間: 2022-10-7 16:19

本帖最後由 Andy2483 於 2022-10-7 16:21 編輯

回復 5# cclo0728

謝謝前輩發表此主題與範例
後學提供另一種方法供前輩參考
今天習得陣列倒入字典與至字典中取出陣列
練習陣列語字典

'刪除結果表舊資料!再帶入新資料
Option Explicit
Sub test_A()
Dim Arr, T, xD, xA, xB
'↑宣告變數

Set xD = CreateObject("Scripting.Dictionary")
'↑令xD是字典

Set xA = Sheets("資料輸入")
'↑令xA是工作表 "資料輸入"

Set xB = Sheets("出貨資料")
'↑令xB是工作表"出貨資料"

T = xA.Cells(Rows.Count, 3).End(3).Row - 4
'↑令T是"資料輸入"表要帶入 "出貨資料"表的列數

Arr = xA.Cells(5, 2).Resize(T, 6)
'↑來源表資料倒入Arr陣列

xD(1) = Arr
'↑Arr陣列倒入字典

xD(2) = xA.Cells(2, 1)
'↑客戶名稱倒入字典

xD(3) = xA.Cells(2, 2)
'↑單號倒入字典

xB.UsedRange.Offset(1, 0).EntireRow.Delete
'↑舊資料刪除

xB.[C2].Resize(UBound(Arr), 6) = xD(1)
'↑帶出陣列放入結果表

xB.[A2].Resize(T, 1) = xD(2)
'↑帶出客戶名稱放入結果表

xB.[B2].Resize(T, 1) = xD(3)
'↑帶出單號放入結果表

End Sub

作者: cclo0728 時間: 2022-10-7 19:54

回復 6# samwang

請教問題我在出貨資料中221007001有10筆，我在資料輸入再輸入10資料，單號可以判定出貨資料最後一欄位+1嗎?
例如單號可以自動當天日期+流水號，221007001
我的想法是輸入明細後，匯至出貨資料時在單號部分就帶入日期加流水號，隔天流水號就回到1
麻煩在指點，謝謝
[attach]35281[/attach]

作者: cclo0728 時間: 2022-10-7 19:55

回復 8# Andy2483
很詳細，還附中文，我測試使用，感謝指點:)

作者: Andy2483 時間: 2022-10-7 21:02

回復 9# cclo0728
前輩很有想法
後學請教前輩
1.出貨資料表是用來列印？列印完就刪除
2.還是累積到隔天才刪除？
3.或者是當天多次累積後列印？
4.還是其它情境？

5.資料輸入會一直累積資料？
6.還是資料輸入匯至出貨資料後就刪除？
7.還是累積資料給其他人員看而已

因為這些疑問會影響此樓的情境
例如：
資料輸入表只是純粹輸入介面表？還是資料庫？

作者: cclo0728 時間: 2022-10-8 08:29

回復 11# Andy2483
感謝耐心看完
5.資料輸入會一直累積資料？
7.還是累積資料給其他人員看而已
因親人想在出貨這塊建立資料，以利後續查詢當時報價與相關資訊
所以會建立出貨明細，以利後續相關其他員工觀看
所以，會想要建立流水號串查當天出貨資訊

作者: Andy2483 時間: 2022-10-8 16:05

本帖最後由 Andy2483 於 2022-10-8 16:13 編輯

回復 12# cclo0728

謝謝前輩再回覆
範例請試試看
[B2].滑鼠快按兩下開始!就會有提示
今天習得資料庫建立
練習陣列與字典
[attach]35287[/attach]

資料輸入:
[attach]35284[/attach]

出貨資料:
[attach]35285[/attach]

資料庫:
[attach]35286[/attach]

作者: Andy2483 時間: 2022-10-9 11:33

本帖最後由 Andy2483 於 2022-10-9 11:35 編輯

回復 12# cclo0728
建議前輩公用的資料庫獨立出來
1.可以設計個excel檔做為界面，各依各的使用者身份及密碼按鈕程序開起資料輸入檔或不必密碼只唯讀開啟資料庫來使用
1.1.開啟後界面即關閉
1.2.界面檔可以多人唯讀開啟且不能另存，即使把界面檔要複製到其它地方也不能使用，方便於管理，且程式可以邊上線使用邊修改程式碼
1.3.資料輸入檔與資料庫檔是獨立的，也都讓使用者按界面檔，按按鈕唯讀開啟，且都具備使用者使用中時，程式開發員修改程式碼的效果，方便更新程式版本
1.4.可以記錄誰使用了檔案存入新的出貨資料
........

Excel vb很好用！前輩很有想法！
後學經驗分享，僅供前輩參考！

作者: cclo0728 時間: 2022-10-11 13:33

回復 14# Andy2483

感謝幫忙，讓我吸收一下，有些要思考一下你寫的邏輯
謝謝，看不懂地方在發問

作者: Andy2483 時間: 2022-10-11 14:16

回復 13# Andy2483

謝謝前輩再回覆
後學把搜尋資料庫決定單號複習並註解了一下!
後學也是藉由這一主題學到變數的宣告將字串與數字做變換
謝謝前輩發表此主題與範例
以下心得供前輩參考

Sub 搜尋資料庫決定單號()

'↓數字與字串可以由一開始的宣告就決定這變數是字串或數字!
Dim Arr, T, xA, xB, xC, N, Mx&, D1$, O1$, D2&, O2&, M1$, M2&
'↑宣告變數

Set xA = Sheets("資料輸入")
'↑令xA是 "資料輸入" 工作表

Set xB = Sheets("出貨資料")
'↑令xB是 "出貨資料" 工作表

Set xC = Sheets("資料庫")
'↑令xA是 "資料庫" 工作表

If xB.Cells(Rows.Count, "B").End(3).Row > 1 Then
'↑如果 "出貨資料" 最後一列列數大於1 !

xB.Activate
'↑畫面就跳到 "出貨資料" 工作表

MsgBox "舊的出貨資料未處理!"
Exit Sub
'↑出現提示!結束程式!

End If
O1 = xA.[B2]: O2 = O1
'↑令O1這變數是 "資料輸入" 工作表.[B2] 字串
'↑令O2這變數是 O1變數轉整數

M1 = xC.Cells(Rows.Count, "B").End(3)
'↑令M1這變數是 "資料庫" 工作表.B欄最後那儲存格字串

M2 = M1
'↑令M2這變數是 M1變數轉整數

D1 = Format(Date, "yymmdd")
'↑令D1是今天日期組成的字串例如22/10/11 轉成 "221011"

D2 = D1 & "001"
'↑令D2是組成今日第一筆出貨單的序號(數字)

If InStr(M1, D1) Then
'↑如果M1字串有包含D1字串

xA.[B2] = M2 + 1
'↑條件若成立!代表 "資料庫" 工作表已經有今天的序號
'↑M2是數字就+1 填到 "資料輸入" 工作表的.[B2]

xA.[B2].Interior.ColorIndex = xlNone
'↑令 "資料輸入" 工作表的.[B2]底色無色

xA.[B2].Font.ColorIndex = 1
'↑令 "資料輸入" 工作表的.[B2]字色是黑色

Else
   xA.[B2] = D2
   '↑否則代表今天還沒有存入今天的出貨單
   '↑"資料輸入" 工作表的.[B2] 就讓他是今天的第一筆序號D2

   xA.[B2].Interior.ColorIndex = xlNone
   '↑令 "資料輸入" 工作表的.[B2]底色無色

   xA.[B2].Font.ColorIndex = 1
   '↑令 "資料輸入" 工作表的.[B2]字色是黑色

End If
End Sub

作者: Andy2483 時間: 2022-10-11 14:53

回復 15# cclo0728

後學的範例邏輯如下
1.想要自動判斷[B2]序號的流水號!必須先將出貨資料表資料存到資料庫並清空出貨資料表資料
2.判讀資料庫最後一筆的序號才給予[B2]新的序號
3.如果按刪除出貨資料_帶入新資料鈕!不管出貨資料表是不是已清空!都會詢問是不是真的要刪除舊的出貨資料
4.出貨資料表可以再做編輯後才連同格式複製到資料庫!出貨資料表可以做這部分的緩衝!
5.資料存入資料庫後要記得存檔!當然前輩也可以讓資料移到資料庫就存檔!

以下是存入資料庫程式碼的心得供參考!

Sub 存入資料庫()
Dim Arr, T, xB, xC
Dim CH
'↑宣告變數

Set xB = Sheets("出貨資料").[A1].CurrentRegion.Offset(1, 0).EntireRow
'↑令xB是 "出貨資料" 工作表有使用的列範圍往下偏移1列的範圍
'就是不包含第一列的意思

Set xC = Sheets("資料庫")
'↑令xC是 "資料庫" 工作表

T = xC.Cells(Rows.Count, "B").End(3).Row + 1
'↑令T是 "資料庫" 工作表的第1 個空白列

xB.Copy xC.Cells(T, "A")
'↑將"出貨資料" 工作表的資料複製到"資料庫" 工作表的第1 個空白列

xB.Delete xlUp
'↑將"出貨資料" 工作表的資料刪除

MsgBox "記得要存檔!"
End Sub

作者: cclo0728 時間: 2022-10-11 18:45

回復 16# Andy2483
我這邊的流程想法，是想要資料輸入完成後，複製到出貨資料，這時候就存檔或列印出貨單

請問我想要直接出貨資料就當資料庫呢?
再輸入客戶時，按鈕產生下一筆流水號(或者說資料輸入完成後，複製到出貨資料時，經由程式給予流水號建立至出貨資料內)
嘗試著修改程式，但好像會卡在流水號判定這邊

作者: Andy2483 時間: 2022-10-11 19:39

回復 18# cclo0728
謝謝前輩回覆
後學現在不方便處理！
如果是只有新序號問題,前輩可再試著改看看！後學的範例有註解！
Samwang的範例跟您的需求更貼近，
如果您急著要用，可以以回覆的方式，請samwang前輩幫忙!

後學干擾了兩位前輩的研討！
向兩位道歉！sorry!

作者: Andy2483 時間: 2022-10-11 20:15

回復 9# cclo0728
這範例有幾個疑問
1.一家廠商一個檔案？還是所有的廠商混合在一起在一個檔案裡？
2.序號是分各廠商累加？還是所有的廠商混合在一起先出先累積序號？

最好是提供更貼近需求情境的範例！

作者: Andy2483 時間: 2022-10-12 08:09

回復 18# cclo0728

前輩早安
範例請試試看
[attach]35294[/attach]

開始情境:
[attach]35295[/attach]

[B2]左鍵快按兩下:
[attach]35296[/attach]

按複製到出貨資料鈕的出貨資料表結果
[attach]35297[/attach]

資料輸入表的結果:
[attach]35298[/attach]

Sub 搜尋出貨資料決定單號()

'↓數字與字串可以由一開始的宣告就決定這變數是字串或數字!
Dim Arr, T, xA, xB, N, Mx&, D1$, O1$, D2&, O2&, M1$, M2&
'↑宣告變數

Set xA = Sheets("資料輸入")
'↑令xA是 "資料輸入" 工作表

Set xB = Sheets("出貨資料")
'↑令xB是 "出貨資料" 工作表

M1 = xB.Cells(Rows.Count, "B").End(3)
'↑令M1這變數是 "資料庫" 工作表.B欄最後那儲存格字串

M2 = M1
'↑令M2這變數是 M1變數轉整數

D1 = Format(Date, "yymmdd")
'↑令D1是今天日期組成的字串例如22/10/11 轉成 "221011"

D2 = D1 & "001"
'↑令D2是組成今日第一筆出貨單的序號(數字)

If InStr(M1, D1) Then
'↑如果M1字串有包含D1字串

xA.[B2] = M2 + 1
'↑條件若成立!代表 "資料庫" 工作表已經有今天的序號
'↑M2是數字就+1 填到 "資料輸入" 工作表的.[B2]

xA.[B2].Interior.ColorIndex = xlNone
'↑令 "資料輸入" 工作表的.[B2]底色無色

xA.[B2].Font.ColorIndex = 1
'↑令 "資料輸入" 工作表的.[B2]字色是黑色

Else
   xA.[B2] = D2
   '↑否則代表今天還沒有存入今天的出貨單
   '↑"資料輸入" 工作表的.[B2] 就讓他是今天的第一筆序號D2

   xA.[B2].Interior.ColorIndex = xlNone
   '↑令 "資料輸入" 工作表的.[B2]底色無色

   xA.[B2].Font.ColorIndex = 1
   '↑令 "資料輸入" 工作表的.[B2]字色是黑色

End If
End Sub

作者: cclo0728 時間: 2022-10-12 09:38

回復 19# Andy2483
抱歉打擾到你這邊，讓你花時間寫程式
還是非常感謝

作者: cclo0728 時間: 2022-10-12 09:39

回復 20# Andy2483

出貨資料為每日出貨明細，所有出貨的資料全部建立在一個分頁
因不需要太複雜，加工廠的親人只會基礎excel
所以，對它們來講越簡單越好

作者: cclo0728 時間: 2022-10-12 09:41

回復 21# Andy2483

Sub 搜尋出貨資料決定單號()

'↓數字與字串可以由一開始的宣告就決定這變數是字串或數字!
Dim Arr, T, xA, xB, N, Mx&, D1$, O1$, D2&, O2&, M1$, M2&
'↑宣告變數

感謝，讓妳百忙之中花時間幫忙，非常謝謝
另外，請教O1&O2是宣告哪端的變數?

作者: Andy2483 時間: 2022-10-12 10:19

回復 24# cclo0728

謝謝前輩回覆
O1,O2是上一版本漏刪除的!不影響執行!

工作空檔練習陣列與字典!
以後可以大幅縮短程式執行時間!

謝謝前輩提出主題與範例,後學可以學到很多!
學生就是該勤勞練習!
猜老師會考什麼? 也很有趣!

題目或範例考得太簡單!也要複雜化!
以檢測自己的思考是否周全!

學十幾年了!熱情依舊!
後學臉皮厚!心得註解也不擔心前輩指正或提醒 !
不違反版規!就好了!
人生的貴人就在發帖/參與/回復主題裡

作者: cclo0728 時間: 2022-10-12 11:04

回復 25# Andy2483
你實在太客氣了，非常謝謝你

作者: cclo0728 時間: 2022-10-12 14:40

回復 21# Andy2483

請問單號B2是使用什麼樣的方式達成像你這樣的設定?

作者: Andy2483 時間: 2022-10-12 16:51

回復 27# cclo0728

運用觸發:
[attach]35299[/attach]

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
If .Address = "$B$2" Then
   Call 搜尋出貨資料決定單號

   Cancel = True
End If
End With
End Sub

作者: Andy2483 時間: 2022-10-13 11:21

本帖最後由 Andy2483 於 2022-10-13 11:26 編輯

回復 27# cclo0728

建議前輩:資料輸入彙整至出貨資料()裡多個程序!
檢查重複!
操作者不知情有重複序號:
[attach]35304[/attach]

出現提示:
[attach]35305[/attach]

跳至出貨資料重複儲存格處
[attach]35306[/attach]

正確不重複序號:
[attach]35307[/attach]

正確彙整至出貨資料表
[attach]35308[/attach]

Option Explicit
Public ERR&
Sub 資料輸入彙整至出貨資料()
Call 檢查出貨資料_序號重複

If ERR = 1 Then
'↑如果"出貨資料" 工作表找到相同序號
ERR = 0
'↑這個跨程式的變數歸零
Exit Sub
End If
Dim Arr, T, xD, xA, xB
'↑宣告變數

Set xD = CreateObject("Scripting.Dictionary")
'↑令xD是字典

Set xA = Sheets("資料輸入")
'↑令xA是工作表 "資料輸入"

Set xB = Sheets("出貨資料")
'↑令xB是工作表"出貨資料"

T = xA.Cells(Rows.Count, 3).End(3).Row - 4
'↑令T是"資料輸入"表要帶入 "出貨資料"表的列數

Arr = xA.Cells(5, 2).Resize(T, 6)
'↑來源表資料倒入Arr陣列

xD(1) = Arr
'↑Arr陣列倒入字典

xD(2) = xA.Cells(2, 1)
'↑客戶名稱倒入字典

xD(3) = xA.Cells(2, 2)
'↑單號倒入字典

xB.Cells(Rows.Count, "C").End(3).Offset(1, 0).Resize(UBound(Arr), 6) = xD(1)
'↑帶出陣列放入結果表

xB.Cells(Rows.Count, "A").End(3).Offset(1, 0).Resize(T, 1) = xD(2)
'↑帶出客戶名稱放入結果表

xB.Cells(Rows.Count, "B").End(3).Offset(1, 0).Resize(T, 1) = xD(3)
'↑帶出單號放入結果表

xA.[B2].Interior.ColorIndex = 3
xA.[B2].Font.ColorIndex = 2

Sheets("出貨資料").Activate
End Sub
Sub 檢查出貨資料_序號重複()
Dim xA, xB, BFind As Range
'↑宣告變數
Set xA = [資料輸入!B2]
'↑令xA是 "資料輸入" 工作表 [B2]
Set xB = [出貨資料!B:B]
'↑令xB是 "出貨資料" 工作表 B欄
Set BFind = xB.Find(xA, LookAt:=xlWhole)
'↑尋找出貨資料!B:B 內容全相同儲存格
'↑(xA, LookAt:=xlPart) 是部分相同儲存格
If Not BFind Is Nothing Then
'↑如果有找到
MsgBox "出貨資料已經有: " & xA & " 序號!"
Sheets("出貨資料").Activate
'↑畫面跳到 "出貨資料" 表
BFind.Activate
'↑選取找到的那個儲存格
ERR = 1
'↑是一個跨程式的變數,如果找到令ERR = 1
End If
End Sub

作者: Andy2483 時間: 2022-10-14 08:00

本帖最後由 Andy2483 於 2022-10-14 08:09 編輯

回復 27# cclo0728

前輩早安
後學早上複習了拆解長序號增加兩欄放入日期與短序號
練習陣列
提供前輩參考!
原出貨資料長序號篩選:
[attach]35310[/attach]

執行程式後產生新檔案可篩選日期:
[attach]35311[/attach]

新檔案可篩選短序號:
[attach]35312[/attach]

以下複習的程式碼供參考:
Option Explicit
Sub 長序號轉_日期_短序號()
Dim Arr, i&, xB, N&, D1 As Date
'↑宣告變數:D1 是日期,N是數字

Set xB = Sheets("出貨資料")
'↑令xB是 "出貨資料" 工作表

Arr = xB.Range(xB.[J1], Cells(xB.UsedRange.EntireRow.Count, 1))
'↑令Arr是"出貨資料" 工作表 A:G欄之間有使用列的區域儲存格值

For i = 2 To UBound(Arr)
'↑設迴圈拆解B欄的長序號

D1 = "20" & Mid(Arr(i, 2), 1, 2) & "/" & Mid(Arr(i, 2), 3, 2) & "/" & Mid(Arr(i, 2), 5, 2)
'↑ "20",加長序號第1個字開始取兩字元="22"
',再加長序號第3個字開始取兩字元="10"
',再加長序號第5個字開始取兩字元="08"
'D1="2022/10/08"字串轉化為日期,因D1宣告為日期

Arr(i, 9) = D1
'↑把D1日期放入Arr的第9欄位置

N = Right(Arr(i, 2), 3)
'↑令N是常序號的右邊3個字元字串轉數字,因N宣告為數字

Arr(i, 10) = N
'↑把N數字放入Arr的第10欄位置

Next
Workbooks.Add
'↑開一個新的檔案

[A1].Resize(UBound(Arr), 10) = Arr
'↑把Arr陣列的資料從[A1]開始倒入新工作表的存格

[I1] = "出貨日期"
[J1] = "當日序號"
Cells.Columns.AutoFit
'↑自動調整欄寬

Cells.Rows.AutoFit
'↑自動調整列高

[2:2].Select
ActiveWindow.FreezePanes = True
'↑第二列以上儲存格凍結窗格

[A1].Select
[A1].AutoFilter
'↑設定篩選

Cells.Borders.LineStyle = xlContinuous
'↑顯示格線
End Sub

作者: Andy2483 時間: 2022-10-15 10:44

各位前輩好
今天後學練習以字典與陣列做統計,並土法煉鋼產生圖表
請各位前輩指正並指導

原始資料:
[attach]35320[/attach]

產生新檔案圖表:
[attach]35321[/attach]

Option Explicit
Sub 客戶出貨金額_統計圖表()
Application.ScreenUpdating = False
'↑執行時螢幕畫面不要跟著變動

Dim Yrr, i&, xD, Arr, Brr, d
'↑宣告變數

Set xD = CreateObject("Scripting.Dictionary")
'↑令xD是字典

Yrr = [出貨資料!A1].CurrentRegion.Offset(1, 0)
'↑令 "出貨資料表"([A1]相鄰非空格所串連起來的儲存格,
'擴展到方正區域的最小範圍,往下偏移一列 )值是陣列 Yrr

For i = 1 To UBound(Yrr)
'↑設迴圈將客戶名利用字典去除重複並累加 G欄的金額
If Yrr(i, 1) <> "" Then
d = Yrr(i, 1)
xD(d) = xD(d) + Yrr(i, 7)
End If
Next

Arr = Application.Transpose(xD.keys)
'↑令Arr 是字典key轉置之後的二維陣列

Brr = Application.Transpose(xD.Items)
'↑令Brr 是字典Item轉置之後的二維陣列

Workbooks.Add
'↑開啟一個新檔案

[A1] = "客戶"
[B1] = "出貨金額統計(NT)"
[A2].Resize(UBound(Arr), 1) = Arr
'↑將 Arr陣列從[A2]貼入值

[B2].Resize(UBound(Brr), 1) = Brr
'↑將 Brr陣列從[B2]貼入值

[A1].CurrentRegion.Sort _
KEY1:=[B1], Order1:=xlDescending, Header:=xlYes
'↑資料有抬頭列的漸減排序

ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Range([A1], Cells([A65536].End(xlUp).Row, "B"))
With ActiveSheet.Shapes("圖表 1")
.ScaleWidth 1.5, msoFalse, msoScaleFromBottomRight
.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft
.IncrementLeft -500
.IncrementTop -500
End With
[A1].Activate
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlPieExploded
ActiveChart.SetSourceData Source:=Range([A1], Cells([A65536].End(xlUp).Row, "B"))
With ActiveSheet.Shapes("圖表 2")
.ScaleWidth 1.5, msoFalse, msoScaleFromBottomRight
.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft
.IncrementLeft -500
.IncrementTop -500
.IncrementTop 400
End With
ActiveSheet.ChartObjects("圖表 2").Activate
ActiveChart.SeriesCollection(1).Select
ActiveChart.SeriesCollection(1).ApplyDataLabels
ActiveChart.SeriesCollection(1).DataLabels.Select
Selection.ShowPercentage = True
Selection.Position = xlLabelPositionOutsideEnd
'↑錄製巨集就可以產生這兩個圖表!視需求調整!

[A1].Activate
Set xD = Nothing
Set Arr = Nothing
Set Brr = Nothing
End Sub

作者: Andy2483 時間: 2022-10-17 08:11

本帖最後由 Andy2483 於 2022-10-17 08:13 編輯

各位前輩好
今天運用此範例整理了:
1.資料表看到哪裡!滑鼠左鍵快按兩下就篩選
2.抬頭列格快按兩下就全部顯示

篩選前滾動卷軸隨機查看資料:
[attach]35324[/attach]

看到想篩選的關鍵字!就左鍵快擊兩次
[attach]35325[/attach]

左鍵快擊兩次後的結果:
[attach]35326[/attach]

想快速全部顯示!就按抬頭列A1儲存格:
[attach]35327[/attach]

以下程式碼心得註解供參考,請各位前輩只正並指導!

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim V$
With Target
'↑以下是有關於左鍵雙擊事件的程序

If .Address = "$A$1" Then
'↑如果左鍵雙擊的位址是 "$A$1"

   If ActiveSheet.AutoFilter Is Nothing Then
   '↑如果工作表沒有使用篩選

      [A1].AutoFilter
      '↑令 [A1]相鄰非空格所串連起來的儲存格,擴展到方正區域的最小範圍
      ',的第一列設定篩選

      Else
      '↑否則如果工作表有使用篩選

         If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
         '↑如果工作表是在篩選中! 就顯示全部資料

   End If
   Cancel = True
End If
If .Column = [A1].Column And .Row > 1 Then
'↑如果左鍵雙擊是 A欄而且是大於第一列

   V = Trim(.Value)
   '↑令V左鍵雙擊格裡頭尾去空白字元的字串

   If Trim(.Value) = "" Then
   '↑如果左鍵雙擊格的值(去除頭尾的空白字元)之後,是空字元

      Cancel = True
      '↑取消事件的執行

      Exit Sub
      '↑結束此程式執行

   End If
   If ActiveSheet.AutoFilter Is Nothing Then
   '↑如果工作表沒有使用篩選

      [A1].AutoFilter
      '↑令 [A1]相鄰非空格所串連起來的儲存格,擴展到方正區域的最小範圍
      ',的第一列設定篩選

      Else
      '↑否則如果工作表有使用篩選

         If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData
         '↑如果工作表是在篩選中! 就顯示全部資料

   End If
   Selection.AutoFilter Field:=1, Criteria1:=V
   '↑第一欄執行篩選!篩選的關鍵字就是雙擊這格的去頭去尾字串

   ActiveWindow.ScrollColumn = 1
   '↑螢幕畫面捲到最左邊

   'ActiveWindow.ScrollRow = 1
   '↑螢幕畫面捲到最上面

   Cancel = True
   '↑取消事件的執行

End If
End With
End Sub

作者: cclo0728 時間: 2022-10-18 14:57

回復 32# Andy2483
高手，都是一直無止盡的進步
還有很多地方要與高手學習:)

作者: Andy2483 時間: 2022-10-21 08:11

回復 33# cclo0728
謝謝前輩回覆
學習是一件很有意思的事
http://forum.twbts.com/thread-387-1-1.html
以上這帖學習到的方法應用在前輩的範例上:
[attach]35361[/attach]

如果按鈕多了!可以用菜單按鈕處理一下!
[attach]35362[/attach]

按鈕後:
[attach]35363[/attach]

作者: Andy2483 時間: 2022-10-21 08:26

學習到了!應用上了!留下足跡!還當作做筆記!
多年以後再回來這帖看看自己學的太少!
新增功能按鈕:
[attach]35364[/attach]

結果1:
[attach]35365[/attach]

結果2,3:
[attach]35366[/attach]

作者: Andy2483 時間: 2022-10-26 08:04

各位前輩早安
今早將統計圖表與分類彙整加入了日期區間的設定功能!
請各位前輩不吝指教!
[attach]35399[/attach]

1.可在紅色框處填入日期
2.如果起始日沒填!抓資料最小日期
3.如果結束日沒填!抓資料最大日期
4.都沒填!各抓資料最小日期&抓資料最大日期
[attach]35400[/attach]
[attach]35401[/attach]

作者: Andy2483 時間: 2022-10-26 08:10

圖表變更如下:
[attach]35402[/attach]
[attach]35403[/attach]

彙整分類變更如下:
[attach]35404[/attach]
[attach]35405[/attach]
[attach]35406[/attach]

作者: Andy2483 時間: 2022-10-26 08:38

主要程式碼變更如下:
Option Explicit
Public Dats As Date, Datn As Date, AC_WO_NA
'↑設為全域變數!給各運用此副程式的主程式運用
Sub 長序號轉_日期_短序號()
Dim Arr, i&, xB, N&, D1 As Date, TTT
'↑宣告變數:D1 是日期,N是數字
Set xB = Sheets("出貨資料")
'↑令xB是 "出貨資料" 工作表
Dats = 0
'↑起始日歸零
Datn = 0
'↑結束日歸零
If IsDate(xB.[I1]) Then
'↑如果出貨資料表的[I1]是日期
Dats = xB.[I1]
'↑起始日就裝入這日期
End If
If IsDate(xB.[J1]) Then
'↑如果出貨資料表的[J1]是日期
Datn = xB.[J1]
'↑結束日就裝入這日期
End If
Arr = xB.Range(xB.[J1], Cells(xB.UsedRange.EntireRow.Count, 1))
'↑令Arr是"出貨資料" 工作表 A:G欄之間有使用列的區域儲存格值
For i = 2 To UBound(Arr)
'↑設迴圈拆解B欄的長序號
D1 = "20" & Mid(Arr(i, 2), 1, 2) & "/" & Mid(Arr(i, 2), 3, 2) & "/" & Mid(Arr(i, 2), 5, 2)
'↑ "20",加長序號第1個字開始取兩字元="22"
',再加長序號第3個字開始取兩字元="10"
',再加長序號第5個字開始取兩字元="08"
'D1="2022/10/08"字串轉化為日期,因D1宣告為日期
Arr(i, 9) = D1
'↑把D1日期放入Arr的第9欄位置
N = Right(Arr(i, 2), 3)
'↑令N是常序號的右邊3個字元字串轉數字,因N宣告為數字
Arr(i, 10) = N
'↑把N數字放入Arr的第10欄位置
Next
Workbooks.Add
'↑開一個新的檔案
AC_WO_NA = ActiveWorkbook.Name
Sheets(1).Name = "出貨資料"
[A1].Resize(UBound(Arr), 10) = Arr
'↑把Arr陣列的資料從[A1]開始倒入新工作表的存格
If Datn = 0 Then
'↑如果結束日是歸零狀態?
Datn = CDate(WorksheetFunction.Max([I:I]))
'↑條件成立!就抓[I:I]裡的最大日期裝進結束日
End If
If Dats = 0 Then
'↑如果起始日是歸零狀態?
Dats = CDate(WorksheetFunction.Min([I:I]))
'↑條件成立!就抓[I:I]裡的最小日期裝進開始日
End If
[I1] = "出貨日期"
[J1] = "當日序號"
Cells.Columns.AutoFit
'↑自動調整欄寬
Cells.Rows.AutoFit
'↑自動調整列高
[2:2].Select
ActiveWindow.FreezePanes = True
'↑第二列以上儲存格凍結窗格
[A1].Select
[A1].AutoFilter
'↑設定篩選
Cells.Borders.LineStyle = xlContinuous
'↑顯示格線
End Sub

Option Explicit
Sub 客戶出貨金額_統計圖表()
Application.ScreenUpdating = False
'↑執行時螢幕畫面不要跟著變動
Call 長序號轉_日期_短序號

Dim Yrr, i&, xD, Arr, Brr, d, c, R
'↑宣告變數
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD是字典
Set Yrr = [出貨資料!A1].CurrentRegion
'↑令 Yrr是 [A1]相鄰非空格所串連起來的儲存格,擴展到方正區域的最小範圍儲存格
c = [出貨資料!A1].End(xlToRight).Column
'↑令C是此表的欄數
R = [出貨資料!A1].End(xlDown).Row
'↑令R是此表的列數
For i = 2 To R
'↑設迴圈將客戶名利用字典去除重複並累加 G欄的金額
If Yrr(i, 9) < Dats Or Yrr(i, 9) > Datn Then
   '↑如果 I欄日期是小於開始日或 I欄日期是大於結束日?
   GoTo 999
    '↑條件成立!就跳到 999的位置繼續執行!
End If
If Yrr(i, 1) <> "" Then
   d = Yrr(i, 1)
   xD(d) = xD(d) + Yrr(i, 7)
End If

999
Next
Arr = Application.Transpose(xD.KEYS)
'↑令Arr 是字典key轉置之後的二維陣列
Brr = Application.Transpose(xD.Items)
'↑令Brr 是字典Item轉置之後的二維陣列
Workbooks.Add
'↑開啟一個新檔案
[A1] = "客戶"
[B1] = "出貨金額統計(NT)/統計區間(" & Dats & "~" & Datn & ")"
'↑圖表標題加入整理日期區間
[A2].Resize(UBound(Arr), 1) = Arr
'↑將 Arr陣列從[A2]貼入值
[B2].Resize(UBound(Brr), 1) = Brr
'↑將 Brr陣列從[B2]貼入值
[A1].CurrentRegion.Sort _
KEY1:=[B1], Order1:=xlDescending, Header:=xlYes
'↑資料有抬頭列的漸減排序
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Range([A1], Cells([A65536].End(xlUp).Row, "B"))
With ActiveSheet.Shapes("圖表 1")
.ScaleWidth 1.5, msoFalse, msoScaleFromBottomRight
.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft
.IncrementLeft -500
.IncrementTop -500
End With
[A1].Activate
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlPieExploded
ActiveChart.SetSourceData Source:=Range([A1], Cells([A65536].End(xlUp).Row, "B"))
With ActiveSheet.Shapes("圖表 2")
.ScaleWidth 1.5, msoFalse, msoScaleFromBottomRight
.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.5, msoFalse, msoScaleFromTopLeft
.IncrementLeft -500
.IncrementTop -500
.IncrementTop 400
End With
ActiveSheet.ChartObjects("圖表 2").Activate
ActiveChart.SeriesCollection(1).Select
ActiveChart.SeriesCollection(1).ApplyDataLabels
ActiveChart.SeriesCollection(1).DataLabels.Select
Selection.ShowPercentage = True
Selection.Position = xlLabelPositionOutsideEnd
'↑錄製巨集就可以產生這兩個圖表!視需求調整!
[A1].Activate
Workbooks(AC_WO_NA).Close False
Set xD = Nothing
Set Arr = Nothing
Set Brr = Nothing
End Sub

作者: Andy2483 時間: 2022-10-27 16:16

今天練習字典,把3種分類(廠商.規格.圖號)各做數量總計與金額總計

[attach]35428[/attach]

選單:
[attach]35424[/attach]

廠商分類/總計:
[attach]35425[/attach]

規格分類/總計:
[attach]35426[/attach]

圖號分類/總計:
[attach]35427[/attach]

主要練習修改:

Y(T & "/數量") = Y(T & "/數量") + Arr(i, 5)
Y(T & "/金額") = Y(T & "/金額") + Arr(i, 7)
Y(T & "|") = Crr  '#1
'↑令客戶 &"|"字串為key ,令Crr為它的item,

~~~
       .Cells(Y(.Name) + 1, 1) = "總計"
      .Cells(Y(.Name) + 1, 5) = Y(Replace(Z, "|", "/數量"))
      .Cells(Y(.Name) + 1, 7) = Y(Replace(Z, "|", "/金額"))
      .Rows(Y(.Name) + 1).Font.Bold = True
      .Columns(1).Font.Bold = True
      .Cells.Columns.AutoFit
      '↑令整表的所有欄位自動調整欄寬
      .Cells(Y(.Name) + 2, 1) = "以上以廠商分類彙整日期區間為: " & Dats & "~" & Datn
      '↑資料最後下一列A欄加入整理日期區間
      .Cells(Y(.Name) + 2, 1).Font.ColorIndex = 5
      '↑資料最後下一列A欄字色變藍色
      .Cells(Y(.Name) + 2, 1).Font.Bold = True
      '↑資料最後下一列A欄字變粗體
   End With

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