Access生成Excel的问题

[zssxfc]

在access窗体上放一个按钮，点击按钮，然后生成excel文件. 要怎么弄？

--------------------------------------
access某个表如下：

姓名 成绩
甲 3
甲 3
甲 8
乙 5
乙 6
丙 8
丙 6
丙 6
丙 5
丙 8
丙 4
丁 6
丁 6
丁 8

现在我要生成excel文件，
使得成如下格式，怎么弄？


甲
3
3
8

乙
5
6

丙
8
6
6
5
8
4

丁
6
6
8

[ewang11]

把行格式转置为列格式,再导出到EXCEL
行列转置函数
http://www.office-cn.net/vvb/thread-38021-1-1.html

[DVS]

在数据库中导出为EXCEL不就行了？哪要那么多的烦琐手续！

[沐NeMo]

用vba 代码也可以做到。
思路：
1.选出一共有多少个人【不重复的】：Select DISTINCT 姓名 From 表 记录集:rs
2.用vba创建一个excel文件
3.循环对每个人做：for i=0 to rs.recordcount-1
选出这人的所有记录:select * from 表 where 姓名='x' 'x就是记录集rs（"姓名")
写入到excel
4.保存excel 和一些后续操作。



我写过的一个类似这样的操作。
Dim Conditions As String
Dim Cnn As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim BegingerName() As String ' 设计师的名称
Dim BegingerNum As Integer '设计师的总数
Dim DevTypes() As String '一个起办师对应的开发种类
Dim DevTypesNum As Integer '一个起办师对应的开发种类的总数
Dim DevTypesUnFDate() As Long '一个起办师开发种类的未完成的数量
Dim DevTypesFDate() As Long '一个起办师开发种类的已完成的数量
Dim i As Integer
Dim j As Integer
Dim RowNumber As Integer '开始写入数据的行数
Dim SMRowNum As Integer
Dim CellDate As Long '单元格的数据

lb.Caption = "取筛选的条件" '----------------------------------------------
Me.Repaint
If CnnStr = "" Then IniMain
Cnn.Open CnnStr
Tmp = ""
If Not IsNull(TxtBegindate) Then
If Not IsNull(TxtEnddate) Then
Conditions = " Where (RsDate between #" & TxtBegindate & "# and #" & TxtEnddate & "#) "
Else
Conditions = " Where (RsDate between #" & TxtBegindate & "# and #" & Date & "#) "
End If
End If
If Len(Conditions) > 0 Then
Tmp = "Select DISTINCT Beginger From SampleDev " & Conditions & " and Beginger>''"
Else
Tmp = "Select DISTINCT Beginger From SampleDev Where beginger>''"
End If
'---------------------------------------------------------------
lb.Caption = "选出不重复的制作设计师"
Me.Repaint
Rst.Open Tmp, Cnn, adOpenKeyset, adLockOptimistic
BegingerNum = 0
If Not (Rst.BOF And Rst.EOF) Then
Rst.MoveLast
Rst.MoveFirst
BegingerNum = Rst.RecordCount
ReDim BegingerName(BegingerNum) As String
For j = 0 To BegingerNum - 1
BegingerName(j) = Rst("Beginger").Value
Rst.MoveNext
Next
End If
Rst.Close
If BegingerNum = 0 Then Exit Sub
'打开EXCEL文件----------------------------------------------------
lb.Caption = "生成Excel文件...创建Execl应用程序..."
Me.Repaint
'Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
xlApp.Workbooks.Add
Set xlBook = xlApp.Workbooks(1)
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Activate
'----------------------------------------------------------------------------
lb.Caption = "激活EXCEL,写入EXCEL数据..."
Me.Repaint
xlSheet.Columns(1).ColumnWidth = 10
FillMyRange xlSheet.Range("A1:F1"), "制作设计师完成工作表", 16, 3, True
FillMyRange xlSheet.Range("A2"), "制作设计师", , 3, True
FillMyRange xlSheet.Range("B2"), "安排数量", , 3, True
FillMyRange xlSheet.Range("C2:D2"), "未完成", , 3, True
FillMyRange xlSheet.Range("E2:F2"), "完成量", , 3, True
RowNumber = 3
'/////////////////////////////////////////////////////////////
'**********************写入数据内容***************************
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
For i = 0 To BegingerNum - 1
'---------------------------制作设计师-----------------
lb.Caption = "选择所有的制作设计师..." & BegingerName(i)
Me.Repaint
If Conditions > "" Then
Tmp = "Select DISTINCT DevType From SampleDev " & Conditions & " and DevType>'' and beginger='" & BegingerName(i) & "' order by DevType"
Else
Tmp = "Select DISTINCT DevType From SampleDev Where DevType>''and beginger='" & BegingerName(i) & "' order by DevType"
End If
Rst.Open Tmp, Cnn, adOpenKeyset, adLockOptimistic
DevTypesNum = 0
If Not (Rst.BOF And Rst.EOF) Then
Rst.MoveLast
Rst.MoveFirst
DevTypesNum = Rst.RecordCount
ReDim DevTypes(DevTypesNum) As String
For j = 0 To DevTypesNum - 1
DevTypes(j) = Rst("DevType")
Rst.MoveNext
Next
End If
Rst.Close
If DevTypesNum > 0 Then
lb.Caption = "制作设计师..." & BegingerName(i) & "-=>" & Join(DevTypes)
Me.Repaint
'---------------------写入起办师----------
Tmp = ""
Tmp = "A" & RowNumber & ":A" & RowNumber + DevTypesNum
FillMyRange xlSheet.Range(Tmp), BegingerName(i), , 3

'---------------------写入起办师的总数量-----
If Conditions > "" Then
Tmp = "Select count(*) From SampleDev " & Conditions & " and beginger='" & BegingerName(i) & "'"
Else
Tmp = "Select count(*) From SampleDev Where beginger='" & BegingerName(i) & "'"
End If
Rst.Open Tmp, Cnn, adOpenKeyset, adLockOptimistic
If Not (Rst.BOF And Rst.EOF) Then
CellDate = IIf(IsNull(Rst(0).Value), 0, Rst(0).Value)
Tmp = "B" & RowNumber & ":B" & RowNumber + DevTypesNum
FillMyRange xlSheet.Range(Tmp), CStr(CellDate), , 3
End If
Rst.Close
'------------新开发,测试办,修改,复办,确认办---------------------
ReDim DevTypesUnFDate(DevTypesNum) As Long
ReDim DevTypesFDate(DevTypesNum) As Long
For j = 0 To DevTypesNum - 1
If Conditions > "" Then
Tmp = "Select count(*) From SampleDev " & Conditions & " and beginger='" & BegingerName(i) & "' and DevType='" & DevTypes(j) & " ' and Complete =False"
Else
Tmp = "Select count(*) From SampleDev Where beginger='" & BegingerName(i) & "' and DevType='" & DevTypes(j) & " ' and Complete =False"
End If
Rst.Open Tmp, Cnn, adOpenKeyset, adLockOptimistic
If Not (Rst.BOF And Rst.EOF) Then
DevTypesUnFDate(j) = IIf(IsNull(Rst(0).Value), 0, Rst(0).Value)
End If
If Conditions > "" Then
Tmp = "Select count(*) From SampleDev " & Conditions & " and beginger='" & BegingerName(i) & "' and DevType='" & DevTypes(j) & " ' and Complete =True"
Else
Tmp = "Select count(*) From SampleDev Where beginger='" & BegingerName(i) & "' and DevType='" & DevTypes(j) & " ' and Complete =True"
End If
Rst.Close
Rst.Open Tmp, Cnn, adOpenKeyset, adLockOptimistic
If Not (Rst.BOF And Rst.EOF) Then
DevTypesFDate(j) = IIf(IsNull(Rst(0).Value), 0, Rst(0).Value)
End If
Rst.Close
Next
'----------------写入相应的制作设计师的完成与未完成情况====================
SMRowNum = 0
SMRowNum = RowNumber
For j = 0 To DevTypesNum - 1
Tmp = "C" & SMRowNum
FillMyRange xlSheet.Range(Tmp), DevTypes(j), , 3
Tmp = "D" & SMRowNum
FillMyRange xlSheet.Range(Tmp), CStr(DevTypesUnFDate(j)), , 3
Tmp = "E" & SMRowNum
FillMyRange xlSheet.Range(Tmp), DevTypes(j), , 3
Tmp = "F" & SMRowNum
FillMyRange xlSheet.Range(Tmp), CStr(DevTypesFDate(j)), , 3
SMRowNum = SMRowNum + 1
Next
'----------------写入总计========================
Tmp = "C" & SMRowNum
FillMyRange xlSheet.Range(Tmp), "总计", , 3
Tmp = "D" & SMRowNum
FillMyRange xlSheet.Range(Tmp), "=SUM(D" & RowNumber & ":D" & SMRowNum - 1 & ")", , 3
Tmp = "E" & SMRowNum
FillMyRange xlSheet.Range(Tmp), "总计", , 3
Tmp = "F" & SMRowNum
FillMyRange xlSheet.Range(Tmp), "=SUM(F" & RowNumber & ":F" & SMRowNum - 1 & ")", , 3
xlSheet.Range("C" & SMRowNum & ":F" & SMRowNum).Font.Color = vbRed
End If
RowNumber = RowNumber + DevTypesNum + 1
Next
Tmp = "A1:F" & RowNumber - 1
xlSheet.Range(Tmp).Borders.LineStyle = 1 '细实线
lb.Caption = "完成写入数据"
Me.Repaint
If Rst.State = 1 Then Rst.Close
Set Rst = Nothing
Cnn.Close
Set Cnn = Nothing
xlApp.Visible = True

[slowgrace]

Dim wbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim StartRange As Excel.Range
Dim f As Variant
……

With rst
    .Open "Employees", strConn, _
        adOpenKeyset, adLockOptimistic
End With


' declare a module-level object
' variable myExcel as Excel.Application
' at the top of the module
Set myExcel = New Excel.Application
' create a new Excel workbook
Set wbk = myExcel.Workbooks.Add
' set the reference to the ActiveSheet
Set wks = wbk.ActiveSheet
' make the Excel application window visible
myExcel.Visible = True


i = 1
' Create the column headings in cells
With rst
    For Each f In .Fields
        With wks
            .Cells(1, i).Value = f.Name
            i = i + 1
        End With
    Next
End With


' specify the cell range that will receive the data (A2)
Set StartRange = wks.Cells(2, 1)
' copy the records from the recordset
' and place in cell A2
StartRange.CopyFromrecordset rst


rst.Close
Set rst = Nothing


' autofit the columns to make the data fit
' wks.Columns("A:Z").AutoFit
wks.Columns.AutoFit
' close the workbook and save the file
wbk.Close SaveChanges:=True, _
    FileName:="C:\ExcelDump.xls"
' quit the Excel application
myExcel.Quit

……

你可以看上面的例子学习如何在程序里生成excel文件。