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 = "时间点"
        .Range("B102").Value = "平均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 = j - 2
            .Cells(102, j).Value = avr


        Next j
        AddChartWith Sht, .Range("B102:K102"), "前字"

        '后字
        .Range("K111").Value = "时间点"
        .Range("K112").Value = "平均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 = j - 11
            .Cells(112, j).Value = avr
        Next j


        AddChartWith Sht, .Range("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