vba筛选-VBA 实战案例：自动按日期筛选数据，另存为新文件

这是我利用业余时间为公司 MES 项目写的一个辅助程序vba筛选，现学现用的成果，学艺不精，花了不少时间。

任务要求：按日期筛选数据，将筛选结果另存为一个新的工作簿。

任务看起来很简单，手动筛选另存一下不就好了，何必写程序，对吧？

如果只是一两个文件，偶尔为之还行，但是生产线这样的Excel数据表有几十个，需要每天处理一次，没有效率，那肯定没人愿意干的。幸运的是这些表格之前也是我为车间设计的，格式统一，这样处理起来就容易了。

刚开始只要求做个简单的宏按钮放在Excel表中，由员工点击按钮导出数据。每次都需要打开表格手动点击，输入要筛选的日期vba筛选，然后导出数据，在动手写代码的过程中，觉得这样不完美，不符合我的“懒人生存法则”。上班时间没空琢磨代码，只能业余时间解决，经过不懈努力，终于圆满完成任务。

程序实现了无需人工执行数据导出操作，自动根据当天日期判断提取数据，并另存为新文件。

代码共享如下：

Sub mes()Application.ScreenUpdating = False  '关闭屏幕更新'    Dim date1 As Date   '定义量变为日期型'    Dim count1 As Integer   '定义变量为整型    Dim file, filelen As String '定义变量为字符型    Dim c1, c2 As Date  '定义变量为日期型    Dim title   '不指定变量类型    title = Range("A1:T1")  '将标题行区域赋值给变量        On Error Resume Next    '忽略错误，继续运行。    fp = ThisWorkbook.Path & "mes"    '将文件夹路径赋值给变量    VBA.MkDir fp    '根据路径变量创建文件夹    i = Application.CountA(Sheets("数据源").Range("B:B")) '计算非空行数'    MsgBox ("共有" & i & "行") '弹出消息窗
    c1 = Cells(i, 2)    '最后一个单元格赋值给变量    c2 = Cells(i - 1, 2)    '倒数第二个单元格赋值给变量    If c1 = Date Then   '判断最后一个日期是否与当日相等，是则执行下面的 DO 循环。        Do While c1 = c2    '当比较结果为真时执行循环            i = i - 1            c1 = Cells(i, 2)    '重新给变量赋值        Loop    '当比较结果为真时返回 DO 循环，否则退出循环。    End If  '退出 IF        file = ActiveWorkbook.Name '返回活动工作薄的名称    filelen = Len(file) '计算文件名长度    file = Left(file, filelen - 5) & c1 & ".xlsx" '文件名后添加日期    file = ThisWorkbook.Path & "mes" & file         '将要判断的文件名及路径保存到变量file中'    MsgBox (file)   '显示文件名    Set cn = CreateObject("adodb.connection")   '建立数据库连接'    cn.Open "provider=microsoft.jet.oledb.4.0;Extended Properties='Excel 8.0';data source=" & ThisWorkbook.FullName '建立 Excel 连接，这句不兼容Office 2019    cn.Open "provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 8.0';data source=" & ThisWorkbook.FullName '建立 Excel 连接    Sql = "select * from [数据源$] where 日期=#" & c1 & "#"   '按日期抽取数据        If Len(Dir(file)) > 0 Then  '判断文件是否存在'        MsgBox "工作薄已存在!"        Exit Sub    '退出程序    Else    '否则执行下面的语句        Dim wb As Workbook, sht As Worksheet   '定义一个workbook 对象和一个 worksheet 对象        Set wb = Workbooks.Add '新建一个工作薄        Set sht = wb.Worksheets(1)        With sht        .Name = "数据"  '修改工作表名称        .Range("A1:F1") = title '设置表头        End With                Sheets("数据").[A2].CopyFromRecordset cn.Execute(Sql)   '将抽取的数据复制到新表的 A2 单元格        Dim x As Long   '设置变量        x = ActiveSheet.Cells(Rows.Count, 2).End(3).Row '计算活动工作表按第 2（B）列数据总行数                      Columns("B:B").Select   '选择 B 列        Cells(2, 2) = "'" & Application.Text(Cells(2, 2), "yyyy-m-d")   '添加单引号，变为强制文本格式        Range("B2").Select  '选择B2单元格        Selection.AutoFill Destination:=Range(Cells(2, "B"), Cells(x, "B")), Type:=xlFillCopy '从 B2 单元格开始向下填充至最后一行数据区
        Columns("E:E").Select   '选择 E 列        Cells(2, 5) = "'" & Application.Text(Cells(2, 5), "h:mm")   '添加单引号，变为强制文本格式        Range("E2").Select  '选择 E2 单元格        Selection.AutoFill Destination:=Range(Cells(2, "E"), Cells(x, "E")), Type:=xlFillCopy '从 E2 单元格开始向下填充至最后一行数据区                Cells.Select    '整表选中        Cells.EntireColumn.AutoFit  '自动对齐        Range("A2").Select  '定位到 A2                wb.SaveAs Filename:=file    '保存工作薄利        ActiveWorkbook.Close    '关闭活动工作薄        savechanges = False '不提示保存更改        Application.ScreenUpdating = True   '打开屏幕更新'        MsgBox "取数据成功"        cn.Close    '关闭变量        Set cn = Nothing    '释放内存    End If '结束判断End Sub '退出程序

在VBA工程中设置打开工作簿时执行这个程序就可以了。

Private Sub Workbook_Open()Application.WindowState = xlMaximized   '窗口最大化    Call mesEnd Sub

限时特惠：本站每日持续更新海量各大内部网赚创业教程，会员可以下载全站资源点击查看详情
站长微信：