【vba源码】导出Excel并添加筛选功能

Hi，大家好呀！

今天又到了我们一周一更新的时间，如果大家最近看过我的直播，知道我每周一会更新，那今天怎么周二才更新了？当然是因为忙！咦？怎么又感觉我说了一堆废话呢！哈哈哈！想和大家唠唠嗑，拉近拉近距离，但好像更尴尬了！

OK，废话不多话，我来想想今天分享点啥呢？

最近一直和导入导出杠上了，所以我们还是来讲讲导出功能。我们在导出Excel数据时，想着导出后可以在Excel做一些数据分析的操作，但每次导出后还要手工选择第一列，添加筛选功能，虽说这个操作花不了太多时间，但每次这么操作一次很是反感，特别是一天要导出很多次的情况下，那能不能在导出时直接添加上筛选呢？

如下图：

要实现这个功能，超简单，最关键的部分，只要一行代码：

objBook.Sheets("sheet1").Rows("1:1").AutoFilter

关键的代码都告诉你了，那剩下的应该都会操作了吧！让我们来看看吧！

1

准备要导出的表/查询

第一步还是一样，我们准备一张要导出的表/查询，那我们还是用之前的那张产品表！

2

添加代码

有了要导出的数据之后，我们就可以来添加一下代码了，我们先创建一个窗体，在窗体上放一个导出按钮。

接着，我们添加一下代码：

Private Sub btnExport_Click()
On Error GoTo Err_ExportToExcel
Dim strName As String
Dim objExcel As Object
Dim objBook As Object
Dim objSheet As Object
Dim rst As Object
Dim objExcelQuery As Object

strName = "产品.xlsx"
'使用文件对话框取得另存为的文件名
With Application.FileDialog(2) 'msoFileDialogSaveAs
.InitialFileName = strName
If .Show Then
strName = .SelectedItems(1)
If Not strName Like "*.xlsx" Then strName = strName & ".xlsx"
Else
strName = ""
End If
End With
If strName = "" Then Exit Sub
DoCmd.Hourglass True

Set objExcel = CreateObject("Excel.Application")
Set objBook = objExcel.Workbooks().Add()
Set objSheet = objBook.Worksheets("sheet1")

Set rst = CurrentDb.OpenRecordset("T_Product")
Set objExcelQuery = objSheet.QueryTables.Add(rst, objSheet.Range("A1"))
With objExcelQuery
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=False
End With
objExcelQuery.Refresh
rst.Close

objBook.Sheets("sheet1").Rows("1:1").AutoFilter
objBook.Worksheets("sheet1").SaveAs strName

If MsgBox("数据已导出，是否打开并查看？", vbQuestion + vbYesNo) = vbYes Then
objExcel.Visible = True
Else
objBook.Saved = True
objExcel.Quit
End If

Exit_ExportToExcel:
Set objExcel = Nothing
Set objBook = Nothing
Set objSheet = Nothing
Set rst = Nothing
DoCmd.Hourglass False
Exit Sub

Err_ExportToExcel:
If Err = 70 Then
MsgBox "无法删除文件 '" & strName & "'，可能该文件已被打开或没有权限。", vbCritical
Else
MsgBox Err.Source & " #" & Err & vbCrLf & vbCrLf & Err.Description, vbCritical
End If
Resume Exit_ExportToExcel
End Sub
3

运行测试

最后，就是运行测试了，导出的Excel就是自动添加上筛选功能，如下图：

好了，大家快去试一下吧！