VBA自動生成圖表

'//此VBA為Excel巨集語言'

  1  
  2 
  3 'Attribute VB_Name = "模塊1"
  4 Sub 製圖表_NBR_G()
  5 'Attribute 製圖表_NBR_G.VB_ProcData.VB_Invoke_Func = " \n14"
  6 '獲取當前文件目錄
  7 Dim CurPath
  8 CurPath = ActiveWorkbook.Path
  9 ' 製圖表_NBR_G 巨集
 10 
 11 '忽略相關彈窗信息
 12 Application.DisplayAlerts = False
 13 ' 獲取今天的時間
 14 Dim DateOfToday As String
 15 DateOfToday = Format$(Date, "yyyymmdd")
 16 'DateOfToday = 20161105
 17 '打開文本取數據
 18 Const ForReading = 1, ForWriting = 2, ForAppending = 8
 19 '格式:路由器IP 店鋪編號 型號
 20 Dim fso, file1, line, params, ip, number, mode
 21 Set fso = CreateObject("Scripting.FileSystemObject")
 22 Set file1 = fso.OpenTextFile(CurPath & "\NBR_G.txt", ForReading, False)
 23 '迴圈寫每一列數據
 24 Do While file1.AtEndOfStream <> True
 25 '讀取一行數據
 26 line = file1.ReadLine
 27 '格式:路由器IP 店鋪編號 型號
 28 params = Split(line)
 29 '獲取IP地址
 30 ip = params(0)
 31 '店鋪編號
 32 number = params(1)
 33 '獲取設備型號
 34 mode = params(2)
 35 
 36 '判斷同一型號設備添加數據結束,製圖標
 37 If number = "END" Then
 38 '刪除掉多餘字元串
 39 Cells.Replace What:="Number of active flows:", Replacement:="", LookAt:= _
 40 xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
 41 ReplaceFormat:=False
 42 
 43 If mode = "1300G" Then
 44 '調整數據格式
 45 Range("B2:AI49").Select
 46 Selection.NumberFormatLocal = "0"
 47 '選擇區域生成圖表
 48 Range("A1:AI49").Select
 49 ActiveSheet.Shapes.AddChart2(240, xlXYScatterSmoothNoMarkers).Select
 50 ActiveChart.SetSourceData Source:=Range("data!$A$1:$AI$49")
 51 End If
 52 
 53 If mode = "1000G" Then
 54 '調整數據格式
 55 Range("B2:I49").Select
 56 Selection.NumberFormatLocal = "0"
 57 '選擇區域生成圖表
 58 Range("A1:I49").Select
 59 ActiveSheet.Shapes.AddChart2(240, xlXYScatterSmoothNoMarkers).Select
 60 ActiveChart.SetSourceData Source:=Range("data!$A$1:$I$49")
 61 End If
 62 
 63 If mode = "1500G" Then
 64 '調整數據格式
 65 Range("B2:B49").Select
 66 Selection.NumberFormatLocal = "0"
 67 '選擇區域生成圖表
 68 Range("A1:B49").Select
 69 ActiveSheet.Shapes.AddChart2(240, xlXYScatterSmoothNoMarkers).Select
 70 ActiveChart.SetSourceData Source:=Range("data!$A$1:$B$49")
 71 End If
 72 
 73 If mode = "2000G" Then
 74 '調整數據格式
 75 Range("B2:C49").Select
 76 Selection.NumberFormatLocal = "0"
 77 '選擇區域生成圖表
 78 Range("A1:C49").Select
 79 ActiveSheet.Shapes.AddChart2(240, xlXYScatterSmoothNoMarkers).Select
 80 ActiveChart.SetSourceData Source:=Range("data!$A$1:$C$49")
 81 End If
 82 
 83 ActiveChart.Axes(xlCategory).Select
 84 '調整圖表橫坐標度量值
 85 ActiveChart.Axes(xlCategory).MaximumScale = 1
 86 ActiveChart.Axes(xlCategory).MajorUnit = 0.05
 87 '調整圖表縱坐標起始值
 88 ActiveChart.Axes(xlValue).MinimumScale = 0
 89 ActiveChart.ClearToMatchStyle
 90 ActiveChart.ChartStyle = 245
 91 '修改圖表title
 92 ActiveChart.ChartTitle.Select
 93 Selection.Format.TextFrame2.TextRange.Characters.Text = mode & "-" & DateOfToday & "-Report"
 94 ActiveChart.ChartArea.Select
 95 '移動到新的chart里
 96 ActiveChart.Location Where:=xlLocationAsNewSheet
 97 End If
 98 
 99 
100 If ip <> "IP" Then
101 '激活data sheet
102 Worksheets("data").Activate
103 '從文本讀取數據寫到B2
104 
105 With ActiveSheet.QueryTables.Add(Connection:= _
106 "TEXT;" & CurPath & "\temp\R_" & ip & "_" & DateOfToday & ".txt", Destination:= _
107 Range("$B$2"))
108 .Name = "R_" & ip & "_" & DateOfToday & ""
109 .FieldNames = True
110 .RowNumbers = False
111 .FillAdjacentFormulas = False
112 .PreserveFormatting = True
113 .RefreshOnFileOpen = False
114 .RefreshStyle = xlInsertDeleteCells
115 .SavePassword = False
116 .SaveData = True
117 .AdjustColumnWidth = False
118 .RefreshPeriod = 0
119 .TextFilePromptOnRefresh = False
120 .TextFilePlatform = 936
121 .TextFileStartRow = 1
122 .TextFileParseType = xlDelimited
123 .TextFileTextQualifier = xlTextQualifierDoubleQuote
124 .TextFileConsecutiveDelimiter = False
125 .TextFileTabDelimiter = True
126 .TextFileSemicolonDelimiter = False
127 .TextFileCommaDelimiter = False
128 .TextFileSpaceDelimiter = False
129 .TextFileColumnDataTypes = Array(1, 1, 1, 1)
130 .TextFileTrailingMinusNumbers = True
131 .Refresh BackgroundQuery:=False
132 End With
133 '將店鋪編號寫到B1
134 Range("B1").Select
135 ActiveCell.FormulaR1C1 = number
136 End If
137 
138 Loop
139 '將生成圖標另存為本目錄下的excel
140 ChDir CurPath
141 ActiveWorkbook.SaveAs Filename:=CurPath & "\NBR_G_Report_" & DateOfToday & ".xlsx", _
142 FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
143 
144 End Sub
145 
146