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