20170711xlVBA批量制图一例

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
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

  

posted @   wangway  阅读(152)  评论(0编辑  收藏  举报
编辑推荐:
· Linux glibc自带哈希表的用例及性能测试
· 深入理解 Mybatis 分库分表执行原理
· 如何打造一个高并发系统?
· .NET Core GC压缩(compact_phase)底层原理浅谈
· 现代计算机视觉入门之:什么是图片特征编码
阅读排行:
· 手把手教你在本地部署DeepSeek R1,搭建web-ui ,建议收藏!
· Spring AI + Ollama 实现 deepseek-r1 的API服务和调用
· 数据库服务器 SQL Server 版本升级公告
· C#/.NET/.NET Core技术前沿周刊 | 第 23 期(2025年1.20-1.26)
· 程序员常用高效实用工具推荐,办公效率提升利器!
点击右上角即可分享
微信分享提示