犯了无数的错,我终于决定把这项工作自动化!

VBA学习手册 4周前 似最初
浏览:223 0 0

嗨喽,鸽了许久不见

本来在群里说要写的文章,因为最近事情实在太多

加上手肘腱鞘囊肿,一直不想动手

今天,终于赶在国庆前把账给还上!

事情是这样滴~

每个月我都有一项工作,那就是需要从另外一张表中摘取某些数据进行汇总!

下面是数据表(数据已做随机数处理)

 

犯了无数的错,我终于决定把这项工作自动化!

这是统计表

犯了无数的错,我终于决定把这项工作自动化!

虽然汇总很简单,只需要有手就能进行

可是每次总要从密密麻麻的数据中准确无误的把数据筛选出来还是得花费十几分钟

最重要的是,脑海里想着5,手却很老实的按下3

这就容易导致出错而且很难被察觉

因此在痛定思痛之后

我决定简单的用VBA把这项工作自动化

大致流程是这样滴:

犯了无数的错,我终于决定把这项工作自动化!

下面是效果,注意看表单刷新:

实现流程第一步:

将数据表及数据汇总表单放置在一起,通过代码自动打开数据表并将数据复制到汇总表中。

实现代码:

Sub Initialize(control As IRibbonControl)
Dim shcount As Integer
shcount = Worksheets.Count '判断表数量
' MsgBox shcount
On Error Resume Next
If Sheets("天然气数据") Is Nothing Then
Worksheets.Add after:=Worksheets(shcount), Count:=1
Worksheets(Worksheets.Count).Name = "天然气数据"
End If
Dim bt As Range, r As Long, c As Long
r = 1 '表头行数
c = 47 '表头列数
Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents '清除汇总表内容
Application.ScreenUpdating = False
Dim FileName As String, wb As Workbook, Erow As Long, fn As String, arr As Variant
FileName = Dir(ActiveWorkbook.Path & "\*.xlsx")
Do While FileName <> ""
If FileName <> ActiveWorkbook.Name Then
Erow = Range("A1").CurrentRegion.Rows.Count + 1
fn = ActiveWorkbook.Path & "\" & FileName
Set wb = GetObject(fn)
Set sht = wb.Worksheets(1) '汇总第一张工作表
arr = sht.Range(sht.Cells(r, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 47))
Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
wb.Close False
End If
FileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "天然气数据表已创建成功,请检查数据准确性,如数据有误,请手动复制到当前文件夹!"
End Sub

犯了无数的错,我终于决定把这项工作自动化!

 

实现流程第二步:

复制原有汇总表单,并自动生成当月表单!

实现代码:

Sub CRTemplate(control As IRibbonControl)

Dim iMonth As Long, Lm As Variant, Tm As Variant
iMonth = Month(Date) '判断当前月份
Lm = ActiveSheet.Name
Tm = iMonth & "月天然气计算"
Sheets(1).Select '选择第一张工作表
Sheets(1).Copy before:=Sheets(1) '选择工作表并复制
Sheets(1).Select
Sheets(1).Name = Tm '重命名新工作表为当月名称
Range("D3").Select
ActiveWindow.SmallScroll Down:=18
Range("D3:D24").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=-45
Range("C3").Select
ActiveSheet.Paste
Range("D3").Value = iMonth & "月20日"
Range("D9").Value = iMonth & "月20日"
Range("E3").Value = iMonth & "数据汇总"
Range("D4", "D8").ClearContents '清除原有数据
Range("D10", "D24").ClearContents '清除原有数据
MsgBox "数据报表模板已生成"
End Sub

犯了无数的错,我终于决定把这项工作自动化!

实现流程第三步:

第三步就是查找数据并将数据填充到报表当中。

实现代码:

Sub Gsreport(control As IRibbonControl)
Dim Cyou_arr As Variant
Dim Cyou_input As Range
Dim Cyou_H As Integer
Sheets("天然气数据").Select '选择天然气工作表表
Cyou_H = Application.InputBox("请输入单元格所在行数") '选中数据所在行
Set Cyou_input = Range("A" & Cyou_H, "AU" & Cyou_H) '选中相应单元格
Cyou_arr = Cyou_input.Value '赋值内容到数组
'MsgBox Cyou_arr(1, 6)

'赋值内容到工作表
Sheets(1).Select '选择当月统计表
Range("D4") = Cyou_arr(1, 2) '调压站修正仪1号
Range("D5") = Cyou_arr(1, 4) '调压站余量表1号
Range("D6") = Cyou_arr(1, 6) '调压站修正仪2号
Range("D7") = Cyou_arr(1, 8) '调压站余量表2号
Range("D8") = Cyou_arr(1, 11) '计量表
Range("D10") = Cyou_arr(1, 23) '1#熔炼炉
Range("D11") = Cyou_arr(1, 25) '1#保温炉
Range("D12") = Cyou_arr(1, 27) '2#熔炼炉
Range("D13") = Cyou_arr(1, 29) '2#保温炉
Range("D14") = Cyou_arr(1, 43) '1#均质炉
Range("D15") = Cyou_arr(1, 45) '2#均质炉
Range("D16") = Cyou_arr(1, 31) '3#熔炼炉
Range("D17") = Cyou_arr(1, 33) '3#保温炉
Range("D18") = Cyou_arr(1, 35) '4#熔炼炉
Range("D19") = Cyou_arr(1, 37) '4#保温炉
Range("D20") = Cyou_arr(1, 39) '5#熔炼炉
Range("D21") = Cyou_arr(1, 41) '5#保温炉
Range("D22") = Cyou_arr(1, 21) '9#轧机线熔炼炉
Range("D23") = Cyou_arr(1, 19) '8#铸造铝合金熔炼炉
Range("D24") = Cyou_arr(1, 17) '7#方铸锭熔炼炉
MsgBox "报表生成完毕,请执行检测!" '返回修正仪1的数据

End Sub

最终,原本需要十几分钟的工作通过代码仅仅10S不到即可完成

而我们要做的。就是将两张表放置到一起,然后轻点三个按钮

当然,这一切都可以使用一个按钮一键完成

但是为了让电脑觉得它有点用

我还是分成了三个步骤

便于检测错误(理论上是不会有误的,只要数据表单行列不变)。

(实际上可以关闭屏幕刷新,甚至只要打开表单就能自动汇总)

当然,这只是简单的查找数据填充

如果是最底层的数据录入

可以借助扫码枪等工具,直接将数据获取后填充到固定区域

比如下面的发票录入小工具

就是使用小程序扫码结合VBA完成的发票内容自动获取。

犯了无数的错,我终于决定把这项工作自动化!

好了,以上就是今天的内容,

学什么不重要,把学习到的内容迁移到可以用的地方才重要!

为大家选了一份比较通俗易懂的VBA 教程,有想法可以学一学。

Excel VBA程序开发自学宝典(第3版)案例文件新版

如有资源,请点击【阅读原文】进行下载

犯了无数的错,我终于决定把这项工作自动化!

本文如无特殊声明即为原创,转载请注明出处!

版权声明:似最初 发表于 2021年9月30日 下午9:10。
转载请注明:犯了无数的错,我终于决定把这项工作自动化! | PP导航 | 工作导航

相关文章