关于ACCESS数据导出到EXCEL

bshchangss

因为原先的帖被版主误以为是EXCEL的提问，被转到EXCEL版来了啊 ，担心EXCEL版看的人少，所以我又重新发了个帖

我把我的附件挂上，请老师们指导，谢谢！

因为里面牵扯的表比较多，所以不做更改把我整个数据库都帖上来，比较乱，请老师将就一下
具体操作如下：
1. 在打开后的主窗体，点击按钮“请点击进入”，因为我的数据是按每条记录的ID号查询的，请确保是在第一条记录，暂时第一条记录的内容对于后面的操作信息包含的较全。
2.请在第二个打开的窗体内输入“2012-1-5“
3.点击按钮“请点击进入”，即将数据导到指定的EXCEL中内


现在我的问题是：
1.怎样能将ACCESS数据导到Excel的指定Sheet表中（如Sheet1）
2.在EXCEL内的黄色区域的信息缺失，因为我不知道怎么修改拷来的源码，请老师帮忙补充。

鱼儿游游

你想导出什么呀？是分别导出到不同的工作表？

bshchangss

恩是的，是有好几张不同类型的表
但现在只放了一个表

Henry D. Sy

给你一个导出查询到指定的excel（具体到工作表，开始行列）
excel请放在与本库同目录下

1. '---------------------------------------------------------------------------------------
   
2. ' Procedure : QueryToExcel
   
3. ' DateTime  : 2008-12-2 00:02
   
4. ' Author    : Henry D. Sy
   
5. ' Purpose   :
   
6. ' 参数      ;strQueryName  查询名
   
7. '            xlsName       Excel 文件名
   
8. '            strShtName    工作表名
   
9. '            Hval;Lval     分别为要导入的开始行和列
   
10. '---------------------------------------------------------------------------------------
    
11. '
    
12. Sub QueryToExcel(ByVal strQueryName As String, ByVal xlsName As String, ByVal _
    
13.                 strShtName As String, ByVal Hval As Integer, ByVal Lval As Integer)
    
14. ' Send the Query results to Excel
    
15. ' for further analysis
    
16.     Dim rs As ADODB.Recordset
    
17.     Dim objXL As Excel.Application
    
18.     Dim objWs As Excel.Workbook
    
19.     Dim fld As ADODB.Field
    
20.     Dim intCol As Integer
    
21.     Dim intRow As Integer
    
22. 
    
23.     Set rs = New ADODB.Recordset
    
24.     ' Get the desired data into a recordset
    
25.     rs.Open strQueryName, CurrentProject.Connection
    
26.     ' Launch Excel
    
27.     Set objXL = New Excel.Application
    
28.     ' Open a  worksheet
    
29.     Set objWs = objXL.Workbooks.Open(CurrentProject.Path & "" & xlsName & _
    
30.                                      ".xls")
    
31.     objWs.Worksheets(strShtName).Activate
    
32.     ' Copy the data
    
33.     ' First the field names　第一行是ACCESS中的列表名
    
34. 
    
35.     For intCol = 0 To rs.Fields.Count - 1  '是获取表中的列数
    
36.         Set fld = rs.Fields(intCol)
    
37.         objWs.Worksheets(strShtName).Cells(Hval, intCol + Lval) = fld.Name  'Excel中（1，1）开始输入列名
    
38.     Next intCol
    
39.     ' Now the actual data　现在开始复制数据
    
40.     intRow = Hval + 1      '你可以修改intRow从第几行开始输入数据，本例中是从第2行开始复制数据
    
41.     Do Until rs.EOF       '你可以修改intCol + 1从第几列开始输入数据，本例中是从第2行第1列开始复制数据
    
42.         For intCol = 0 To rs.Fields.Count - 1
    
43.             objWs.Worksheets(strShtName).Cells(intRow, intCol + Lval) = _
    
44.             rs.Fields(intCol).Value
    
45.         Next intCol
    
46.         rs.MoveNext
    
47.         intRow = intRow + 1
    
48.     Loop
    
49.     ' Make the worksheet visible
    
50.     objXL.Visible = True    '打开Excel表查看数据
    
51.     rs.Close
    
52.     Set rs = Nothing
    
53. 
    
54. End Sub

复制代码

54pan123

不错