导出EXCEL的奇怪问题，通过日期查询能导出，其它条件查询导出是空的

daviee

参照网上的导出EXCEL的方法，通过查询后逐条遍历导出的方法，查询是平台生成的通用查询模块，不同的条件能查询出结果，但是在导出到EXCEL时，只有通过日期查询才能导出到EXCEL,通过其它条件查询，导出的EXCEL表是空的。。。，因为要控制导出的结果，所以用的是逐条遍历导出的方法。不知道下面的代码哪出错了。 Test.zip (10.41 MB, 下载次数: 36)

2019-4-28 07:41 上传

点击文件名下载附件
下载积分: 金钱 -1 点

Private Sub cmdExport_Click()
On Error GoTo Err_Show

    Dim rs As Object        
    Dim xlApp As Object     'Excel.Application
    Dim xlBook As Object    'Excel.Workbook
    Dim xlSheet As Object   'Excel.Worksheet
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add    '添加一个新的Book
    Set xlSheet = xlApp.ActiveSheet     '使用当前的Sheet
    Dim i As Long
    Dim j, ii As Long
    Dim strExcelName As String
    Dim strPath As String
    Dim strSql As String
    Dim cn As Object

    '【事务处理】
    Set cn = CurrentProject.Connection
    cn.BeginTrans           '开始事务

    strSql = Me.sfmSubForm.Form.RecordSource

    If InStr(1, strSql, "Select") = 0 Then strSql = "select * from " & strSql & ";"
    If Me.sfmSubForm.Form.FilterOn = True Then
        strSql = Replace(strSql, ";", "") '去掉;号
        strSql = "select * from (" & strSql & ") as qryA where " & Me.sfmSubForm.Form.Filter
    End If

    Set rs = gf_OpenRecordset(strSql, cn, 1, 1)

    '先写入标题(可以考虑用DAO的字段标题属性 rs(i-1).Properties("Caption"))
    For i = 1 To 12
'   For i = 1 To rs.Fields.Count
        xlSheet.Cells(1, i) = rs(i - 1).Name
    Next

    '写入数据，从第2行开始写数据
        ii = 1
        Do While Not rs.EOF
            xlSheet.Cells(1 + ii, 1) = rs("供应商")
            xlSheet.Cells(1 + ii, 2) = rs("快递日期")
       '     xlSheet.Cells(1 + ii, 3) = rs("销售单号")
            If rs("数量") > 0 Then xlSheet.Cells(1 + ii, 3) = rs("销售单号") Else xlSheet.Cells(1 + ii, 3) = ""
            xlSheet.Cells(1 + ii, 4) = rs("客户料号")
            xlSheet.Cells(1 + ii, 5) = rs("产品料号")
            xlSheet.Cells(1 + ii, 6) = rs("描述")
            xlSheet.Cells(1 + ii, 7) = rs("单位")
            xlSheet.Cells(1 + ii, 8) = rs("数量")
            xlSheet.Cells(1 + ii, 9) = rs("快递单号")
            xlSheet.Cells(1 + ii, 10) = rs("快递公司")
            xlSheet.Cells(1 + ii, 11) = rs("收货工厂")
            xlSheet.Cells(1 + ii, 12) = rs("备注")
            rs.MoveNext
            ii = ii + 1
        Loop
    rs.Close
    xlApp.Visible = True

    For j = 1 To 12
        xlSheet.Cells(1, j).Interior.ColorIndex = 45   '填充颜色为橙色
    Next

    xlApp.Range("A1" & ii).Borders.LineStyle = 1

    strExcelName = Me.Caption & Format(Date, "_yyyymmdd")

    '调整列宽
    xlSheet.Columns.EntireColumn.AutoFit
    xlApp.Visible = True
    xlBook.Activate
'   ExportToExcel = True
    xlApp.Worksheets(1).Name = Me.Caption & Format(Date, "_yyyymmdd")      'SHEET名称

    DoCmd.SetWarnings False
    With xlApp.Application.FileDialog(msoFileDialogSaveAs)
    .Title = "请保存文件"
    .ButtonName = "保存"
    .InitialView = msoFileDialogViewDetails
    .InitialFileName = "C:\Users\Administrator\DeskTop\" & Me.Caption & Format(Date, "yyyymmdd") & " .xls"
    If .Show = -1 Then
    xlBook.SaveAs Me.Caption & Format(Date, "yyyymmdd") & " .xls"
    Else
    Debug.Print "用户取消"
    End If
    End With

Err_Exit:
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Set rs = Nothing
    Exit Sub
Err_Show:
    MsgBox "导出出错，请重新尝试" & vbCrLf & Err.Description, "导出出错"
    On Error Resume Next
    '出错则清掉文件，避免有多个Excel进程
    xlBook.Close False
    If xlApp.Workbooks.Count = 0 Then xlApp.Quit
    GoTo Err_Exit
End Sub

tmtony

Do While Not rs.EOF
在这一句前面加上
msgbox rs.recordcount
看看 有否数据

daviee

tmtony 发表于 2019-4-28 10:21
Do While Not rs.EOF
在这一句前面加上
msgbox rs.recordcount

通过日期查询导出时，有数据记录，但是选其它条件查询导出时，0记录

daviee

检查发现是这段出问题

  If Me.sfmSubForm.Form.FilterOn = True Then
        strSql = Replace(strSql, ";", "") '去掉;号
        strSql = "select * from (" & strSql & ") as qryA where " & Me.sfmSubForm.Form.Filter
    End If
qryA是查询模块中的一个变量，改不了。重新把这个导出EXCE的过程做成为一个函数，解决了这个问题。