请问 为什么我的datagrid导出excel只有一列

Question

我想把显示在datagrid 的数据导出至excel 
可是不知道什么原因 导出的时候只有一列是第一列 而且 有两个excel表
请问 我错在那里了 代码如下
Set xlapp = CreateObject("excel.application")
Set xlbook = xlapp.workbooks.Add
Set xlsheet = xlbook.worksheets(1)
xlapp.Visible = True
On Error Resume Next
If Err.Number <> 0 Then Set xlapp = CreateObject("Excel.Application")
Set xlbook = xlapp.workbooks.Add
Set xlsheet = xlbook.ActiveSheetFor k = 1 To dgrecord.Columns.Count
xlsheet.cells(1, k) = dgrecord.Columns(k - 1).Caption
Next k
For i = 1 To RsQRecord.RecordCount + 1
    For j = 0 To dgrecord.Columns.Count
        xlsheet.cells(i + 1, j + 1) = RsQRecord(j)
        xlsheet.cells(i + 1, j + 1) = dgrecord.Columns(j).CellText(dgrecord.RowBook(j))
    Next j
    RsQRecord.MoveNext
Next i

Answer 1

不要循环了,
直接这样:
xlsheet.Cells.CopyFromRecordset RsQRecordxlsheet.Rows(1).InsertFor k = 1 To dgrecord.Columns.Count
xlsheet.cells(1, k) = dgrecord.Columns(k - 1).Caption
Next k

Answer 2

那就是你的 RsQRecord没有数据

Answer 3

我所有的代码 包括查询那部分的 
Option Explicit
Dim strsql As String
Dim i, j, k As Integer
Dim xlapp As Variant
Dim xlbook As Variant
Dim xlsheet As Variant
Private Sub cmnexcel_Click()
Set xlapp = CreateObject("excel.application")
Set xlbook = xlapp.workbooks.Add
Set xlsheet = xlbook.worksheets(1)
xlapp.Visible = True
On Error Resume Next
If Err.Number <> 0 Then Set xlapp = CreateObject("Excel.Application")
Set xlbook = xlapp.workbooks.Add
Set xlsheet = xlbook.ActiveSheet
xlsheet.cells.CopyFromRecordset RsQRecordxlsheet.Rows(1).InsertFor k = 1 To dgrecord.Columns.Count
xlsheet.cells(1, k) = dgrecord.Columns(k - 1).Caption
Next kEnd SubPrivate Sub cmnquery_Click()   
    strsql = "select * from bgsb where  "       '//给定义好的字符变量赋予SQL语句"
    '//判断单选框中时,判断办公设备单位单选框选中时
    If optdanwei.Value = True Then
       If Trim(txbgdanwei.Text) = "" Then
          MsgBox "请输入查询的单位", vbExclamation + vbOKOnly, "查询失败"
   
          Exit Sub
       End If
       strsql = strsql & " 单位 = '" & Trim(txbgdanwei.Text) & "'"
      ' //判断消防名称单选框选中时
    ElseIf optname = True Then
        If Trim(txbgname.Text) = "" Then
           MsgBox "请输入的办公设备名称", vbExclamation + vbOKOnly, "查询失败"
   
         Exit Sub
        End If
        strsql = strsql & " 名称 = '" & Trim(txbgname.Text) & "'"
       
    Else
      MsgBox "请选择一个查询条件", vbExclamation + vbOKOnly, "查询失败"
   
      Exit Sub
    End If
       
   '//当单选框选中时
    If RsQBgong.State = adStateClosed Then
        RsQBgong.Open "bgsb", DBCON, adOpenKeyset, adLockOptimistic, adCmdTable
    End If
    If RsQBgong.State = adStateOpen Then
       RsQBgong.Close
    End If
  
    If RsQBgong.State = adStateClosed Then '//执行StrSQL中的
       RsQBgong.Open strsql, DBCON, adOpenKeyset, adLockOptimistic, adCmdText
   
     dgrecord.Refresh        '//刷新网格
        Set dgrecord.DataSource = RsQBgong.DataSource
        lblcount.Caption = RsQBgong.RecordCount        '//将记录条数显示在标签上
       
       txbgdanwei.Text = Empty        '//请空文本框
        txbgname.Text = Empty
       
   
   End If
   
End SubPrivate Sub cmnreturn_Click()
Unload MeEnd SubPrivate Sub Form_Load()
If RsQBgong.State = adStateOpen Then
    RsQBgong.Close
End If
RsQBgong.Open "bgsb", DBCON, adOpenKeyset, adLockPessimistic, adCmdTableIf RsQBgong.RecordCount > 0 Then      '//如果记录集中有记录
   Set dgrecord.DataSource = RsQBgong.DataSource    '//设置网格的数据源
End If
 lblcount.Caption = RsQBgong.RecordCount
End Sub

Answer 4

靠,上面写着RsQRecord,下面怎么都是RsQBgong啊,怎么是两个个记录集xlsheet.Cells.CopyFromRecordset RsQRecord '--这个改成你要导出数据的纪录集,就是和网格绑定的那个

Answer 5

结果 出来了 但是 有两个excel表 
一个 空的  一个有数据 关闭其中的一个 两个都关闭了

Answer 6

支持楼上
并且Set xlbook = xlapp.workbooks.Add
Set xlsheet = xlbook.worksheets(1)
xlapp.Visible = True
On Error Resume Next
If Err.Number <> 0 Then Set xlapp = CreateObject("Excel.Application")
Set xlbook = xlapp.workbooks.Add
Set xlsheet = xlbook.ActiveSheet
这里好象有问题 或许是你出现两个Excel表的原因???

Answer 7

Private Sub cmnexcel_Click()
Set xlapp = CreateObject("excel.application")
Set xlbook = xlapp.workbooks.Add
Set xlsheet = xlbook.worksheets(1)On Error Resume Next
If Err.Number <> 0 Then Set xlapp = CreateObject("Excel.Application")
Set xlbook = xlapp.workbooks.Add
Set xlsheet = xlbook.Worksheets("Sheet1")xlsheet.cells.CopyFromRecordset RsQRecordxlsheet.Rows(1).InsertFor k = 1 To dgrecord.Columns.Count
xlsheet.cells(1, k) = dgrecord.Columns(k - 1).Caption
Next kxlapp.Visible = TrueEnd Sub

Answer 8

aruima() 你好！
我也在做datagrid导出excel表的功能，我碰到的问题也是两个Excel表，
且只显示 标题没有数据能否将你改好的Private Sub cmnexcel_Click()代码
传上来看看啊，谢谢！