关于数据导出到Excel的问题。急急急~~！

关于数据导出到Excel的问题。我采用别人的程序，想实现打开TEMPLATE目录下的Excel并把当前的数据导出到里面，完了以另存的形式保存在名为报表的目录下，TEMPLATE目录下的Excel不改变。以下的程序能打开，能导出数据，但是保存在原来的目录下，在退出保存时把TEMPLATE目录下的Excel也改变了。希望能给改改。谢谢！ Private Sub Command2_Click()
 '打印报表On Error GoTo err
Dim i, j As Integer
Set xlApp = CreateObject("excel.application")
    xlApp.Visible = True
    Set xlBook = xlApp.Workbooks.Open(App.Path + "\TEMPLATE\消费信息.xls")
    With xlBook.Worksheets("sheet1")
        .Activate
        .Range("i1").Value = Me.Text1.Text
        For i = 1 To frmMDI.adoInformation.Recordset.RecordCount
            .Range("A" + Trim(str(i + 2))).Value = DataGrid1.Columns(0).Text
            .Range("B" + Trim(str(i + 2))).Value = DataGrid1.Columns(1).Text
            .Range("C" + Trim(str(i + 2))).Value = DataGrid1.Columns(2).Text
            .Range("D" + Trim(str(i + 2))).Value = DataGrid1.Columns(3).Text
            .Range("E" + Trim(str(i + 2))).Value = DataGrid1.Columns(4).Text
            .Range("F" + Trim(str(i + 2))).Value = DataGrid1.Columns(5).Text
            .Range("G" + Trim(str(i + 2))).Value = DataGrid1.Columns(6).Text
            .Range("H" + Trim(str(i + 2))).Value = DataGrid1.Columns(7).Text
            .Range("I" + Trim(str(i + 2))).Value = DataGrid1.Columns(8).Text
            .Range("J" + Trim(str(i + 2))).Value = DataGrid1.Columns(9).Text
            .Range("K" + Trim(str(i + 2))).Value = DataGrid1.Columns(10).Text
            .Range("L" + Trim(str(i + 2))).Value = DataGrid1.Columns(11).Text
            DataGrid1.Row = i
         Next i
            .Range("H" + Trim(str(i + 3))).Value = Format(Now, "YYYY年MM月DD日")
            xlBook.SaveAs (App.Path & "\报表\"+ Format(DTPicker1.Value, "YYYY年MM月DD日") + "-" + Format(DTPicker1.Value, "YYYY年MM月DD日") + "查询报表.xls")
   End With
   Exit Sub
err:
 'MsgBox "本文件名包表已经存在,请选择别的文件名!", vbOKOnly + vbInformation, "提示"
End Sub

解决方案 »

  1.   

    不会吧？不过我不明白为什么要xlApp.Visible = True呢？
      

  2.   

    不过我不明白为什么要xlApp.Visible = True
    主要是显示填数的过程.
      

  3.   

    你这样的导出方式很不好，特别是直接对datagrid本身去操作。给你介绍一种办法，是lihonggen的办法，比较好，直接利用recordset操作，是偶认为最好的一种办法。你可以把代码稍微改写一下Visual Basic 导出到 Excel 提速之法 
           Excel 是一个非常优秀的报表制作软件，用VBA可以控制其生成优秀的报表，本文通过添加查询语句的方法，即用Excel中的获取外部数据的功能将数据很快地从一个查询语句中捕获到EXCEL中,比起往每个CELL里写数据的方法提高许多倍。将下文加入到一个模块中,屏幕中调用如下ExporToExcel("select * from table")则实现将其导出到EXCEL中Public Function ExporToExcel(strOpen As String)
    '*********************************************************
    '* 名称：ExporToExcel
    '* 功能：导出数据到EXCEL
    '* 用法：ExporToExcel(sql查询字符串)
    '*********************************************************
    Dim Rs_Data As New ADODB.Recordset
    Dim Irowcount As Integer
    Dim Icolcount As Integer
        
        Dim xlApp As New Excel.Application
        Dim xlBook As Excel.Workbook
        Dim xlSheet As Excel.Worksheet
        Dim xlQuery As Excel.QueryTable
        
        With Rs_Data
            If .State = adStateOpen Then
                .Close
            End If
            .ActiveConnection = Cn
            .CursorLocation = adUseClient
            .CursorType = adOpenStatic
            .LockType = adLockReadOnly
            .Source = strOpen
            .Open
        End With
        With Rs_Data
            If .RecordCount < 1 Then
                MsgBox ("没有记录!")
                Exit Function
            End If
            '记录总数
            Irowcount = .RecordCount
            '字段总数
            Icolcount = .Fields.Count
        End With
        
        Set xlApp = CreateObject("Excel.Application")
        Set xlBook = Nothing
        Set xlSheet = Nothing
        Set xlBook = xlApp.Workbooks().Add
        Set xlSheet = xlBook.Worksheets("sheet1")
        xlApp.Visible = True
        
        '添加查询语句，导入EXCEL数据
        Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
        
        With xlQuery
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = True
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .PreserveColumnInfo = True
        End With
        
        xlQuery.FieldNames = True '显示字段名
        xlQuery.Refresh
        
        With xlSheet
            .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
            '设标题为黑体字
            .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
            '标题字体加粗
            .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
            '设表格边框样式
        End With
        
        With xlSheet.PageSetup
            .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称："   ' & Gsmc
            .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
            .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
            .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
            .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
            .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
        End With
        
        xlApp.Application.Visible = True
        Set xlApp = Nothing  '"交还控制给Excel
        Set xlBook = Nothing
        Set xlSheet = NothingEnd Function
    注:须在程序中引用'Microsoft Excel 9.0 Object Library'和ADO对象,机器必装Excel 2000本程序在Windows 98/2000,VB 6 下运行通过
      

  4.   

    '这样试一下.Private Sub Command2_Click()
     '打印报表
    Dim xlApp As New Excel.Application, xlBook As Excel.Workbook
    Dim xlsheet As Excel.Worksheet
    On Error GoTo err
    Dim i, j As Integer
        xlApp.Visible = True
        Set xlBook = xlApp.Workbooks.Open(App.Path + "\TEMPLATE\消费信息.xls")
        Set xlsheet = xlBook.Worksheets(1)
        With xlsheet
            .Activate
            .Range("i1").Value = Me.Text1.Text
            For i = 1 To frmMDI.adoInformation.Recordset.RecordCount
                .Range("A" + Trim(Str(i + 2))).Value = DataGrid1.Columns(0).Text
                .Range("B" + Trim(Str(i + 2))).Value = DataGrid1.Columns(1).Text
                .Range("C" + Trim(Str(i + 2))).Value = DataGrid1.Columns(2).Text
                .Range("D" + Trim(Str(i + 2))).Value = DataGrid1.Columns(3).Text
                .Range("E" + Trim(Str(i + 2))).Value = DataGrid1.Columns(4).Text
                .Range("F" + Trim(Str(i + 2))).Value = DataGrid1.Columns(5).Text
                .Range("G" + Trim(Str(i + 2))).Value = DataGrid1.Columns(6).Text
                .Range("H" + Trim(Str(i + 2))).Value = DataGrid1.Columns(7).Text
                .Range("I" + Trim(Str(i + 2))).Value = DataGrid1.Columns(8).Text
                .Range("J" + Trim(Str(i + 2))).Value = DataGrid1.Columns(9).Text
                .Range("K" + Trim(Str(i + 2))).Value = DataGrid1.Columns(10).Text
                .Range("L" + Trim(Str(i + 2))).Value = DataGrid1.Columns(11).Text
                DataGrid1.Row = i
             Next i
                .Range("H" + Trim(Str(i + 3))).Value = Format(Now, "YYYY年MM月DD日")
       End With
       xlBook.SaveAs (App.Path & "\报表\" + Format(DTPicker1.Value, "YYYY年MM月DD日") + "-" + Format(DTPicker1.Value, "YYYY年MM月DD日") + "查询报表.xls")
       xlBook.Close False
       xlApp.Quit
       Set xlApp = Nothing
       Exit Sub
    err:
     'MsgBox "本文件名包表已经存在,请选择别的文件名!", vbOKOnly + vbInformation, "提示"End Sub
      

  5.   

    首先感谢各位的支持，我用tztz520(午夜逛街)的方法试了一下，不能运行。程序是我在从别的上面拷过来的，在他的程序上运行是没问题的。但是我这里就出现点小问题，就是不能另存在另外的目录下。希望大家还是想想办法。
      

  6.   

    If Dir(App.Path & "\报表", vbDirectory) = "" Then
       MkDir App.Path & "\报表"
    End If
      

  7.   

    可以先按照命名规则将 Template 下的 xls 复制到 "报表" 目录中，打开目标文件进行输出
      

  8.   

    在别人的程序运行下，关闭Excel后，就自动存到指定的目录了。在我这里运行的时候感觉没有运行next i后面的东西，关闭的时候就直接存到原目录了。 大家有没有办法啊！！！，请帮小弟解决这个问题啊，真的是很急的！！！！！