前面是某位大神给的代码，我想把他改下，加个commondialog控件，添加个文件保存位置和默认名的，但是改了后文件直接没有保存。

Public access As New ADODB.Connection
Public res As New ADODB.Recordset
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Private Sub Command1_Click()
Dim str As String
Dim sql As String
str = Text1.Text
res.Close
sql = "SELECT * FROM ziliao where 商品名 like '%" & Text1 & "%'  ORDER BY 编号"
res.Open sql, access, 1, 3
Set DataGrid1.DataSource = res
res.Close
End Sub

Private Sub Command2_Click()
Dim Irow, Icol As Integer
Dim Irowcount, Icolcount As Integer
Dim Fieldlen() As Integer
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)

sql = "SELECT * FROM ziliao ORDER BY 编号"
res.Open sql, access, 1, 3
Set DataGrid1.DataSource = res
With res
Irowcount = .RecordCount '记录总数
Icolcount = .Fields.Count '字段总数
ReDim Fieldlen(Icolcount) As Integer
res.MoveFirst
For Irow = 1 To Irowcount + 1
For Icol = 1 To Icolcount
Select Case Irow
Case 1 '在Excel中的第一行加标题

xlSheet.Cells(Irow, Icol).Value = RTrim(.Fields(Icol - 1).Name)
Case 2 '将数组FIELDLEN()存为第一条记录的字段长
If IsNull(.Fields(Icol - 1)) = True Then
Fieldlen(Icol) = LenB(RTrim(.Fields(Icol - 1).Name))
Else
aa = RTrim(.Fields(Icol - 1).Name)
Fieldlen(Icol) = LenB(aa)
End If
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
xlSheet.Cells(Irow, Icol).Value = RTrim(.Fields(Icol - 1))
Case Else
Fieldlen1 = LenB(.Fields(Icol - 1))
If Fieldlen(Icol) < Fieldlen1 Then
xlSheet.Columns(Icol).ColumnWidth = Fieldlen1
Fieldlen(Icol) = Fieldlen1
Else
xlSheet.Columns(Icol).ColumnWidth = Fieldlen(Icol)
End If
xlSheet.Cells(Irow, Icol).Value = .Fields(Icol - 1)
End Select
Next
If Irow <> 1 Then
If Not .EOF Then .MoveNext
End If
Next
'    With xlSheet
'   .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Name = "黑体"
'   .Range(.Cells(1, 1), .Cells(1, Icol - 1)).Font.Bold = True
'   .Range(.Cells(1, 1), .Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
'    End With
'xlApp.Visible = True
Dim aaa
aaa = MsgBox("是否保存该Excel表?", vbYesNo, "提示窗口")
If aaa = vbYes Then
CommonDialog1.FileName = "报表"
CommonDialog1.Filter = "Xls文件(*.Xls)|*.Xls|所有文件(*.*)|*.*"
CommonDialog1.ShowSave
On Error GoTo ErrSave
NewSheet.SaveAs CommonDialog1.FileName
' MsgBox "保存成功"
newxls.Quit
ErrSave:
Exit Sub
MsgBox Err.Description, , "提示窗口"
End If
Set xlApp = Nothing
End With
End Sub

Private Sub Form_Load()

m = 0
If Dir(App.Path + "\资料.mdb") <> "" Then
    access.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + App.Path + "\资料.mdb;Persist Security Info=False;Jet OLEDB:Database Password=123"
    access.Open
         
    Set res.ActiveConnection = access '设置rs1的ActiveConnection属性，指定与其关联的数据库连接
    
    res.CursorLocation = adUseClient  '设置游标类型

    res.CursorType = adOpenDynamic '设置动态游标
    res.Open "SELECT * FROM ziliao ORDER BY 编号", access, 1, 3  '打开记录集，将从表Departments中读取的结果集保存到记录集res中
       DataGrid1.Refresh  '刷新表格
    Set DataGrid1.DataSource = res '将DataSource连接到数据库
    res.MoveFirst     
Else
  MsgBox "找不到数据库"
  
End If
res.Close
End Sub

NewSheet.SaveAs CommonDialog1.FileName
--〉应该是 xlbook.save ......

大神威武，但是出了个问题如图

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
后面加一句取消EXCEL操作提示
xlapp.DisplayAlerts = False

又变成只读了蛋疼啊 大神

之前执行程序时出错导致文件被打开没有关闭，再任务管理器里将EXCEL关闭再执行.

3q我知道了，谢谢大神

最近一直被一个问题困扰，特地请教大神，问题：我有一个excel模板，怎么把数据从vb导到excel？
以前我的做法是以模板为参照，先在指定单元格输入数据，然后给新excel表设定格式，这样的工作量有点大
所以有没有方法直接导进模板，然后另存为？

假设 Rs.Open SQL,Conn,1,1 打开记录源
先逐列将字段名输入到EXCEL第一行
选取EXCEL单元格 A2，直接复制就可以了，程序如下
For Fld_j = 0 To Rs.Fields.Count - 1
    xlSheet.Cells(1, Fld_j + 1) = Rs.Fields(Fld_j).Name
Next Fld_j
xlSheet.Range("A2").CopyFromRecordset Rs