首页 > 代码库 > 20170711xlVBA批量制图一例
20170711xlVBA批量制图一例
Public Sub GatherDataPicker() Application.ScreenUpdating = False Application.DisplayAlerts = False Application.Calculation = xlCalculationManual Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>" ‘On Error GoTo ErrHandler Dim StartTime, UsedTime As Variant StartTime = VBA.Timer ‘>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Dim wb As Workbook Dim Sht As Worksheet Dim OpenWb As Workbook Dim OpenSht As Worksheet Const SHEET_INDEX = 1 Const OFFSET_ROW As Long = 1 Dim FolderPath As String Dim FileName As String Dim FileCount As Long ‘>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = ThisWorkbook.Path .AllowMultiSelect = False .Title = "请选取Excel工作簿所在文件夹" If .Show = -1 Then FolderPath = .SelectedItems(1) Else MsgBox "您没有选中任何文件夹,本次汇总中断!" Exit Sub End If End With If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\" ‘>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Set wb = Application.ThisWorkbook ‘工作簿级别 ‘Set Sht = wb.ActiveSheet ‘Sht.Cells.Clear ‘FolderPath = ThisWorkbook.Path & "\" FileCount = 0 FileName = Dir(FolderPath & "*.xls*") Do While FileName <> "" If FileName <> ThisWorkbook.Name Then FileCount = FileCount + 1 Set OpenWb = Application.Workbooks.Open(FolderPath & FileName) With OpenWb ‘On Error Resume Next Set OpenSht = OpenWb.Worksheets(1) Debug.Print OpenSht.Name ‘On Error GoTo 0 ‘If Not OpenSht Is Nothing Then InsertFormula OpenSht ‘Else ‘ End If .Close True End With End If FileName = Dir Loop ‘>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> UsedTime = VBA.Timer - StartTime MsgBox "本次耗时:" & Format(UsedTime, "0.000秒"), vbOKOnly, "NextSeven Excel Studio QQ嘻嘻哈哈" ErrorExit: Set wb = Nothing Set Sht = Nothing Set OpenWb = Nothing Set OpenSht = Nothing Set Rng = Nothing Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic Application.StatusBar = False Exit Sub ‘>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ErrHandler: If Err.Number <> 0 Then MsgBox Err.Description & "!", vbCritical, "NextSeven Excel Studio QQ嘻嘻哈哈" ‘Debug.Print Err.Description Err.Clear Resume ErrorExit End If End Sub Sub ChartActiveSheet() InsertFormula ActiveSheet End Sub Sub InsertFormula(ByVal Sht As Worksheet) With Sht endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row For i = 1 To endrow If .Cells(i, 1).Value Like "*T*" Then .Cells(i - 1, "C").FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)" .Cells(i - 1, "C").AutoFill Destination:=.Cells(i - 1, "C").Resize(1, 18), Type:=xlFillDefault .Cells(i, "C").FormulaR1C1 = "=5*LOG10(R[-1]C/MIN(R[-4]C:R[-2]C))/LOG10(MAX(R[-4]C:R[-2]C)/MIN(R[-4]C:R[-2]C))" .Cells(i, "C").AutoFill Destination:=.Cells(i, "C").Resize(1, 18), Type:=xlFillDefault End If Next i For Each shp In Sht.Shapes shp.Delete Next ‘前字 .Range("B101").Value = "http://www.mamicode.com/时间点" .Range("B102").Value = "http://www.mamicode.com/平均T值" For j = 2 + 1 To 2 + 9 s = 0 n = 0 For i = 1 To endrow If .Cells(i, 1).Value Like "*T*" Then ‘Debug.Print TypeName(.Cells(i, j).Value) If .Cells(i, j).Value <> "" Then n = n + 1 s = s + .Cells(i, j).Value End If End If Next i ‘Debug.Print s avr = s / n .Cells(101, j).Value = http://www.mamicode.com/j - 2"B102:K102"), "前字" ‘后字 .Range("K111").Value = "http://www.mamicode.com/时间点" .Range("K112").Value = "http://www.mamicode.com/平均T值" For j = 11 + 1 To 11 + 9 s = 0 n = 0 For i = 1 To endrow If .Cells(i, 1).Value Like "*T*" Then If .Cells(i, j).Value <> "" Then n = n + 1 s = s + .Cells(i, j).Value End If End If Next i avr = s / n .Cells(111, j).Value = http://www.mamicode.com/j - 11"K112:T112"), "后字" End With Set wb = Nothing Set Sht = Nothing End Sub Sub AddChartWith(ByVal Sht As Worksheet, ByVal Rng As Range, ByVal Title As String) Dim cht As Chart Sht.Shapes.AddChart2(227, xlLineMarkers).Select Set cht = Sht.Shapes(Sht.Shapes.Count).Chart cht.SetSourceData Source:=Rng cht.ChartTitle.Text = Title Set cht = Nothing End Sub
20170711xlVBA批量制图一例
声明:以上内容来自用户投稿及互联网公开渠道收集整理发布,本网站不拥有所有权,未作人工编辑处理,也不承担相关法律责任,若内容有误或涉及侵权可进行投诉: 投诉/举报 工作人员会在5个工作日内联系你,一经查实,本站将立刻删除涉嫌侵权内容。