在vb中将搜索的内容添加到新建的excel中

Private Sub Command4_Click()
Dim rs As New ADODB.Recordset
Dim sql As String
Dim connstr As String
connstr = "provider=microsoft.jet.oledb.4.0;" & "data source=" & App.Path & "/data.mdb;"
'***********************************************************************************************
Dim Application As Object
Dim WorkBook As Object
Dim Sheet As Object
'***********************************************************************************************

Select Case Label12.Caption
Case "all"
sql = "select * from members"
conn.Open (connstr)
rs.Open sql, conn, 1, 1

If rs.RecordCount = 0 Then
MsgBox "无记录"
rs.Close
conn.Close
Exit Sub
Else

With CommonDialog1
.DialogTitle = "请输入excel名字"
.Filter = "Microsoft Office Excel 工作簿(*.xls)|*.xls"
.ShowSave
End With
If CommonDialog1.FileName = "" Then Exit Sub
Set Application = CreateObject("Excel.Application") '建立EXCEL对象

Workbooks.Add
ActiveWorkbook.SaveAs (CommonDialog1.FileName)
Set WorkBook = Application.Workbooks.Open(CommonDialog1.FileName)


Set Sheet = WorkBook.Sheets.Add() '建立一个新表单

For t = 1 To rs.RecordCount

Sheet.Cells(t, 1).Value = rs.Fields(1).Value '向EXCEL里写数据
Sheet.Cells(t, 2).Value = rs.Fields(2).Value '向EXCEL里写数据
Sheet.Cells(t, 3).Value = rs.Fields(3).Value '向EXCEL里写数据
Sheet.Cells(t, 4).Value = rs.Fields(4).Value '向EXCEL里写数据
Sheet.Cells(t, 5).Value = rs.Fields(5).Value '向EXCEL里写数据
Sheet.Cells(t, 6).Value = rs.Fields(6).Value '向EXCEL里写数据
Sheet.Cells(t, 7).Value = rs.Fields(7).Value '向EXCEL里写数据
rs.MoveNext
Next


ActiveWorkbook.Save '保存
MsgBox "导出成功"
' Application.Visible = True 'EXCEL使之可见


WorkBook.Close
Set WorkBook = Nothing
Set Sheet = Nothing
Set Application = Nothing
rs.Close
conn.Close
End If
end sub