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 |
【推荐】编程新体验,更懂你的AI,立即体验豆包MarsCode编程助手
【推荐】凌霞软件回馈社区,博客园 & 1Panel & Halo 联合会员上线
【推荐】抖音旗下AI助手豆包,你的智能百科全书,全免费不限次数
【推荐】轻量又高性能的 SSH 工具 IShell:AI 加持,快人一步
· 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)
· 程序员常用高效实用工具推荐,办公效率提升利器!