VBA：集保+籌碼+信用交易 圖表整理 自動化

 這段時間，每周花了不少時間在分享資料給眾多網友們，但近期發現人怪怪的，決定也把這部分寫成自動化，製作快速生成照片的模組，以利分享。

VBA CODE:

流程:

資料行標題判斷>排序資料>設定資料範圍>設備Y軸標籤>產生圖表>設定圖表>輸出圖表>插入照片>刪除檔案

	Sub OUT_DRAW()
	Set OUT = Sheets("OUT") '設定要使用的工作表
	S1 = Sheets("OUT").Range("A2000").End(xlUp).Row
	Set Tag = Sheets("OUT").Range("A1:N" & S1) '標題範圍
	Add = 0
	For Each i In Tag
	If InStr(i.Value, "變化") > 0 Then '標題關鍵字判斷
	TEMP_ADDRESS = Split(i.Address, "$")
	ActiveSheet.Range("A" & "1:" & "N" & S1).Sort Key1:=ActiveSheet.Range(TEMP_ADDRESS(1) & "1"), Order1:=xlDescending, Header:=xlYes, _
	OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
	:=xlStroke, DataOption1:=xlSortNormal '排序
	Set rngSourceData = ActiveSheet.Range(TEMP_ADDRESS(1) & 1 & ":" & TEMP_ADDRESS(1) & S1) '資料來源
	Set rngXValues = ActiveSheet.Range("A2" & ":" & "A" & S1) '標題資料設定
	If Add Mod 2 = 0 Then '產生圖表，位置判斷
	Set MYCHART = OUT.ChartObjects.Add(Left:=OUT.Columns("Q").Left, Width:=640 * 3, Top:=OUT.Rows(1 + (Add) * 24).Top, Height:=480 * 3)
	OUT.Range("Q" & 2 + (Add) * 24).Activate
	LEFT_ADDRESS = OUT.Columns("Q").Left
	TOP_ADDRESS = OUT.Rows(1 + (Add) * 24).Top
	Width_ADDRESS = 640 * 3
	Height_ADDRESS = 480 * 3
	Else
	Set MYCHART = OUT.ChartObjects.Add(Left:=OUT.Columns("AQ").Left, Width:=640 * 3, Top:=OUT.Rows(1 + (Add - 1) * 24).Top, Height:=480 * 3)
	OUT.Range("AQ" & 2 + (Add - 1) * 24).Activate
	LEFT_ADDRESS = OUT.Columns("AQ").Left
	TOP_ADDRESS = OUT.Rows(1 + (Add - 1) * 24).Top
	Width_ADDRESS = 640 * 3
	Height_ADDRESS = 480 * 3
	End If
	With MYCHART.Chart '設定圖表
	.ChartType = xlBarClustered
	.SetSourceData Source:=rngSourceData, PlotBy:=xlColumns
	.HasTitle = True
	.ChartTitle.Text = i
	.SeriesCollection(1).XValues = rngXValues
	.ChartGroups(1).GapWidth = 10
	.Axes(xlCategory).TickLabels.Font.Size = 26
	.Axes(xlCategory).TickLabelSpacing = 1
	.Legend.Delete
	.ChartTitle.Font.Size = 32
	End With
	With MYCHART.Chart
	With .SeriesCollection(1).Format.Fill
	.Visible = msoTrue
	.ForeColor.RGB = RGB(79, 129, 189)
	.Transparency = 0
	MYCHART.Chart.SeriesCollection(1).InvertIfNegative = True
	MYCHART.Chart.SeriesCollection(1).InvertColor = RGB(255, 0, 0)
	.Solid
	End With
	.Export Filename:=ThisWorkbook.Path & "\" & i & ".BMP", Filtername:="BMP" '輸出圖表
	With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & i & ".BMP") '插入圖表
	.Left = LEFT_ADDRESS
	.Top = TOP_ADDRESS
	.Width = Width_ADDRESS
	.Height = Height_ADDRESS
	End With
	MYCHART.Delete '刪除圖表物件
	Kill ThisWorkbook.Path & "\" & i & ".BMP" '刪除檔案
	End With
	Add = Add + 1
	End If
	Next
	End Sub

view raw gistfile1.txt hosted with ❤ by GitHub

一點小工具分享。