将DataGrid中的数据存入Excel ,我不会

?

解决方案 »

  1.   

    '将listView中的数据导出到Excel的例子
    '希望对你有帮助'这是我自己写的
    Private Sub PrintToExcel()
    On Error GoTo ErrTrap
        Dim xlsApp As New Excel.Application    Dim xlsBook As New Excel.Workbook
        Dim xlsSheet As New Excel.Worksheet
        Dim i As Integer
        Dim j As Integer
        Dim xlsRow As Integer
        Dim xlsCol As Integer
        
        xlsCol = lsvShow.ColumnHeaders.Count - 3
        xlsRow = 3
        
        Set xlsBook = xlsApp.Workbooks.Add
        Set xlsSheet = xlsBook.Worksheets(1)
        xlsSheet.PageSetup.Orientation = xlLandscape     '横向打印
        frm_Wait.Show
        
        xlsApp.Columns(1).NumberFormatLocal = "@"
        '写入列名
        For i = 1 To lsvShow.ColumnHeaders.Count - 3
            xlsApp.Cells(xlsRow, i) = " " & Trim(lsvShow.ColumnHeaders(i).Text)
            xlsApp.Columns(i).Select
            xlsApp.Selection.ColumnWidth = lsvShow.ColumnHeaders(i).Width / 100
        Next i
        'xlsApp.Columns(1).AutoFit
        xlsRow = xlsRow + 1
        '写入列表内容
        For i = 1 To lsvShow.ListItems.Count
            xlsApp.Cells(xlsRow, 1) = Trim(lsvShow.ListItems(i).Text)
            For j = 1 To lsvShow.ColumnHeaders.Count - 4
                xlsApp.Cells(xlsRow, j + 1) = Trim(lsvShow.ListItems(i).SubItems(j))
                xlsApp.Cells(xlsRow, j + 1).WrapText = True
            Next j
            xlsRow = xlsRow + 1
        Next i
        
        '写入标题和时间
        xlsApp.Range(xlsApp.Cells(1, 1), xlsApp.Cells(1, xlsCol)).Select
        With xlsApp.Selection
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        xlsApp.Cells(1, 1) = labKeyName.Caption
        xlsApp.Cells(1, 1).Font.Size = 24
        xlsApp.Cells(1, 1).Font.Bold = True
        xlsApp.Cells(2, 1) = "打印时间：" & Date
        
        '设置边框
        xlsApp.Range(xlsApp.Cells(3, 1), xlsApp.Cells(xlsRow, xlsCol)).Select
        With xlsApp.Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlHairline
            .ColorIndex = xlAutomatic
        End With
        With xlsApp.Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With xlsApp.Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With xlsApp.Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlHairline
            .ColorIndex = xlAutomatic
        End With
        With xlsApp.Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlHairline
            .ColorIndex = xlAutomatic
        End With
        With xlsApp.Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlHairline
            .ColorIndex = xlAutomatic
        End With
        xlsApp.Visible = True
        frm_Wait.Visible = False
        Call VBA.AppActivate(xlsBook.name)
        
        On Error GoTo 0
        Exit Sub
    ErrTrap:
        On Error GoTo 0
    End Sub
    下面引用自小马哥'*********************************************************
    '* 名称：OutDataToExcel
    '* 功能：将MsFlexGrid控件中显示的内容输出到Excel表格中进行打印
    '*********************************************************
    Public Sub OutDataToExcel(Flex As MSFlexGrid)    '导出至Excel
        Dim s As String
        Dim i As Integer
        Dim j As Integer
        Dim k As Integer
        On Error GoTo Ert
        Me.MousePointer = 11
        Dim Excelapp As Excel.Application
        Set Excelapp = New Excel.Application
        On Error Resume Next
        DoEvents
        Excelapp.SheetsInNewWorkbook = 1
        Excelapp.Workbooks.Add
        Excelapp.ActiveSheet.Cells(1, 3) = s
        Excelapp.Range("C1").Select
        Excelapp.Selection.Font.FontStyle = "Bold"
        Excelapp.Selection.Font.Size = 16
        With Flex
            k = .Rows
            For i = 0 To k - 1
                For j = 0 To .Cols - 1
                   DoEvents
                   Excelapp.ActiveSheet.Cells(3 + i, j + 1) = "'" & .TextMatrix(i, j)
                Next j
            Next i
        End With
        Me.MousePointer = 0
        Excelapp.Visible = True
        Excelapp.Sheets.PrintPreview
    Ert:
        If Not (Excelapp Is Nothing) Then
            Excelapp.Quit
        End If
    End Sub
      

  2.   


    http://www.csdn.net/develop/read_article.asp?id=14952
      

  3.   

    前提你的数据库 必须不要有什么限制？（不要有必须字段，不要有不允许为空）
     Call ConRe  是连接 Microsoft Access 表 我想不用我多说了吧？在这里我就不写了Public conexl As ADODB.Connection
    Public reexl As ADODB.Recordset
    Public appexl As Excel.Application
    Public workexl As Excel.Workbook
    Public workexlsh As Excel.Worksheet
    Public rowexl As Excel.RangePublic Sub ConReExcel(PathOpen1 As String) 连接Excel 
    Set conexl = New ADODB.Connection
        conexl.Open "provider=microsoft.jet.oledb.4.0;data source= " & PathOpen1 & " ;extended properties=excel 8.0;"
        conexl.CursorLocation = adUseClient
        Set reexl = New Recordset
    End Sub数据导出
    Public Sub Excel_o(Table_Name As String, Data_Table As DataGrid, TitleString As String, PathSave As String)
     Call ConRe
     re.Open "select * from " & Table_Name & "", con, adOpenDynamic, adLockBatchOptimistic
     
     If Data_Table.ApproxCount + 1 > 0 Then
       
       Set appexl = New Excel.Application
           
       Set workexl = appexl.Workbooks.Add
       
       Set workexlsh = workexl.Worksheets.Add
           workexlsh.Name = TitleString
            Set rowexl = workexlsh.Rows(1)
       
       For i = 1 To Data_Table.Columns.Count
            Data_Table.Row = 0
              rowexl.Cells(1, i) = re.Fields(i - 1).Name
               
       Next
        
        On Error Resume Next
       
       For j = 0 To Data_Table.ApproxCount - 1
              
              For i = 1 To Data_Table.Columns.Count
                 Data_Table.Col = i - 1
                rowexl.Cells(j + 2, i) = Data_Table.Text
               
               
               Next
          Data_Table.Row = Data_Table.Row + 1
       Next
       
         workexlsh.SaveAs PathSave
          appexl.Quit
      End If
    End Sub数据导入
    Public Sub Excel_I(Table_Name As String, Table_Name_exl As String, Data_Table As DataGrid, pathopen As String)
         Call ConReExcel(pathopen)
         reexl.Open "select * from [" & Table_Name_exl & "$] order by 还阅编号 ", conexl, adOpenDynamic, adLockBatchOptimistic
         
         Set Data_Table.DataSource = reexl
         
         Call ConRe
          
         Data_Table.Row = 0
          On Error Resume Next
         For j = 0 To Data_Table.ApproxCount
             
            
             Data_Table.Col = 0
             sql1 = "insert into  " & Table_Name & "( " & reexl.Fields(0).Name & ") values ('" & Data_Table.Text & "') "
             Bianhao = Data_Table.Text
             con.Execute sql1
             
             For i = 1 To Data_Table.Columns.Count - 1
                Data_Table.Col = i
                Sql = "update " & Table_Name & " set " & reexl.Fields(i).Name & "='" & Data_Table.Text & "' where 还阅编号='" & Bianhao & "'  "
                con.Execute Sql
              Next i
              
              Data_Table.Row = Data_Table.Row + 1
          
              Next j
              
           MsgBox "数据成功导入！ ", vbInformation, "数据导入提示 "
            
            Call TuShu_LiShiJiLu
            Call TuShu_TongJi
             
    End Sub
      

  4.   

    我用的 “http://www.csdn.net/develop/read_article.asp?id=14952
     Visual Basic 导出到 Excel 提速之法    lihonggen0（原作）”
    但遇到新问题了！
    用了上述代码，在开始的大概2、30次都很好，但突然有一次出现错误提示
    Run-time error '1004’
    命令不可用。因为使用该应用程序的许可已过期！
    这是怎么回事呢？具体是运行下面一条语句出错：
    Set xlBook = xlApp.Workbooks().Add 
    会不会是Excel的控件也有使用次数限制？
      

  5.   

    问题还没解决，把Office重装一次又好了。但不知什么时候会出问题