求导出按钮代码

qp370982

各位老师：
           单选按钮是与籍贯列的内容相对应的，将选中的单选按钮（籍贯）相对应的内容导出为excel
要求：1、都在一个excel文件中，但不同的籍贯为不同的不同的工作表2、工作表的名子就是籍贯名
3、能够自己设定导出excel文件的保存路径

[ 本帖最后由 qp370982 于 2008-12-22 19:12 编辑 ]

Henry D. Sy

需要引用 Microsoft Office 11

qp370982

Dim diaFs As FileDialog提示用户定义类型未定义

Henry D. Sy

1. Dim ctl As Control
   
2. Private Sub Command13_Click()
   
3.     Dim Qdf As DAO.QueryDef
   
4.     Dim rs As New ADODB.Recordset
   
5.     Dim strSQL As String, strCriteria As String
   
6.     Dim strPath As String
   
7.     Dim diaFs As FileDialog
   
8.     Set diaFs = Application.FileDialog(msoFileDialogSaveAs)
   
9.     With diaFs
   
10.         .Title = "导出为........"
    
11.         .Show
    
12.     End With
    
13.     If diaFs.SelectedItems.Count > 0 Then
    
14.         strPath = diaFs.SelectedItems(1)
    
15.     End If
    
16.     If strPath = "" Then
    
17.         strPath = CurrentProject.Path & "\out.xls"
    
18.     ElseIf Right(strPath, 4) <> ".xls" Then
    
19.         strPath = strPath & ".xls"
    
20.     End If
    
21.     Set Qdf = CurrentDb.QueryDefs("Q")
    
22.     For Each ctl In Me.Controls
    
23.         If TypeOf ctl Is OptionButton Then
    
24.             If ctl Then
    
25.                 strCriteria = strCriteria & "'" & ctl.Name & "',"
    
26.             End If
    
27.         End If
    
28.     Next
    
29.     If strCriteria = "" Then
    
30.         strSQL = "select * from 表1 order by 籍贯"
    
31.     Else
    
32.         strSQL = "select * from 表1 where 籍贯 in (" & strCriteria & ") order by 籍贯"
    
33.     End If
    
34.     Qdf.SQL = strSQL
    
35.     strSQL = "select distinct 籍贯 from Q"
    
36.     With rs
    
37.         Set Qdf = CurrentDb.QueryDefs("Out")
    
38.         .Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    
39.         Do While Not .EOF
    
40. 
    
41.             strSQL = "select * from 表1 where 籍贯='" & .Fields(0) & "'"
    
42.             Qdf.SQL = strSQL
    
43.             DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Out", strPath, , .Fields(0)
    
44.             .MoveNext
    
45.         Loop
    
46.         .Close
    
47.     End With
    
48.     Set rs = Nothing
    
49.     Set Qdf = Nothing
    
50.     Set diaFs = Nothing
    
51. End Sub
    
52. 
    
53. Private Sub Form_Load()
    
54.     For Each ctl In Me.Controls
    
55.         If TypeOf ctl Is OptionButton Then
    
56.             ctl = False
    
57.         End If
    
58.     Next
    
59. End Sub

复制代码

[ 本帖最后由 Henry D. Sy 于 2008-12-24 08:11 编辑 ]

qp370982

保存路径能设置为对话框形式吗，谢谢

Henry D. Sy

Private Sub Command13_Click()
    Dim Qdf As DAO.QueryDef
    Dim rs As New ADODB.Recordset
    Dim strSQL As String, strCriteria As String
    Dim ctl As Control

    If IsNull(Me.Text14) Then
        MsgBox "Enter the Path frist"
        Me.Text14.SetFocus
        Exit Sub
    End If
    Set Qdf = CurrentDb.QueryDefs("Q")
    For Each ctl In Me.Controls
        If TypeOf ctl Is OptionButton Then
            If ctl Then
                strCriteria = strCriteria & "'" & ctl.Name & "',"
            End If
        End If
    Next
    If strCriteria = "" Then
        strSQL = "select * from 表1 order by 籍贯"
    Else
        strSQL = "select * from 表1 where 籍贯  in (" & strCriteria & ") order by 籍贯"
    End If
    Qdf.SQL = strSQL
    strSQL = "select distinct 籍贯 from Q"
    With rs
        .Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
        Do While Not .EOF
            Set Qdf = CurrentDb.QueryDefs("Out")
            strSQL = "select * from 表1 where 籍贯='" & .Fields(0) & "'"
            Qdf.SQL = strSQL
            DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Out", Me.Text14, , .Fields(0)
            .MoveNext
        Loop
        .Close
    End With
    Set rs = Nothing
    Set Qdf = Nothing
End Sub

[ 本帖最后由 Henry D. Sy 于 2008-12-23 20:31 编辑 ]

qp370982

求老师帮忙给改改，在下没学过vb，只学过c，这是老板要的，谢谢，

qp370982

求老师帮忙给改改，在下没学过vb，只学过c，这是老板要的，谢谢，

yesterday

版主 的帖子很厉害，强烈建议参考使用

yesterday

我想这样作可能好一些：因为导入方法是对表操作的，所以你首先要把筛选结果临时放在一个表或查询中。假定临时表为temp，在导出按钮中加入sql，delete * from temp
"insert into temp selete * from 表1 where 籍贯= 选项值
然后采用 TransferSpreadsheet方法