用vb创建excel，谁有例子。在线等待

Question

我现在想用vb创建excel，谁有例子。能给我一个吗？谢谢！

Answer 1

http://www.dapha.net/down/list.asp?id=1251

Answer 2

Dim appExcel As Object 
     Set appExcel = CreateObject("Excel.Application") 
     appExcel.Visible = True 
     appExcel.Workbooks.Open "G:\My Documents\book2.xls"

Answer 3

Dim objExcel As Object,i as Integer, N as IntegerSet objExcel = VBA.CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.Workbooks.Add
objExcel.Sheets(1).Name = "Data Sheet"
objExcel.Sheets(2).Name = "Result Sheet"
objExcel.Sheets(1).Activate
N=10For i = 1 To N
    objExcel.Cells(i + 2, 1).Value =i
Next i

Answer 4

在使用VBA创建EXCEL时,最好不要用CreateObject(),这样等你操作完成后EXCEL还保留在内存里,你想打开EXCEL文档时,就不能打开.就直接用Set appExcel = New Excel.Application 也可

Answer 5

请问小于，用add方法时，workbook的名字都默认为book1
请问能指定book名吗？
Dim objExcel As Object,i as Integer, N as IntegerSet objExcel = VBA.CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.Workbooks.Add
objExcel.Sheets(1).Name = "Data Sheet"
objExcel.Sheets(2).Name = "Result Sheet"
objExcel.Sheets(1).Activate
N=10For i = 1 To N
    objExcel.Cells(i + 2, 1).Value =i
Next i

Answer 6

With xlSheet
         .Range("a2:b2").Merge
         .Range("a2:b2") = "aaaaa" & contractnum
         .Range("c2:e2").Merge
         .Range("c2") = "bbbbbbbbb& factorynum & "-" & fname
         .Range("f2:h2").Merge
         .Range("f2") = "ccc"
         .Range("I2:J2").Merge
         .Range("I2") = "dddddddd" & tmptext1
         .Range("k2:L2").Merge
         .Range("k2") = "³ö»õÆÚ:" & tmptext2
         .Rows(3).RowHeight = 48
        End With
        Set myrange = xlSheet.Range("A3:D3")
        myrange = Array("1111", "222222", "2222333", "4444")
        myrange.Font.bold = True
        xlSheet.Rows(3).HorizontalAlignment = 3
        xlSheet.Rows(3).WrapText = True

Answer 7

Private Sub ComExport_Click()
    Dim xlApp As New Excel.Application
    Dim xlBook As New Excel.Workbook   '定義Excel工作簿對象
    Dim xlSheet As New Excel.Worksheet '定義Excel工作表對象
    
    Dim line As Integer, M As Integer, n As Integer
    
    Dim savepath As String  '定義保存路徑
    
    CommonDialog1.CancelError = True   '設置cancelError為ture
    
    On Error GoTo errhandler
    CommonDialog1.Flags = cdlOFNHideReadOnly
    
    
    CommonDialog1.FileName = "Report"
    
    CommonDialog1.DefaultExt = ".xls"
    
    CommonDialog1.Filter = "Excel(*.xls)|*.xls|Text(*.txt)|*.txt"
    
    CommonDialog1.FilterIndex = 1
    
    CommonDialog1.Flags = &H2
    
    CommonDialog1.ShowSave
    
    If ERR.Number = cdlCancel Then
    
        Exit Sub
    
    End If
    
    savepath = CommonDialog1.FileName
    
    ''######################以下是匯入到excel
    
     Set xlApp = CreateObject("Excel.Application")
    ' xlApp.Visible = True         '根据操作人是否需見到Excel此處可設TRUE 或FALSE
    xlApp.Visible = False
    
    Set xlBook = xlApp.Workbooks.add
    On Error Resume Next
    Set xlSheet = xlBook.Worksheets(1)
    If k = 2 Then  'by 機台編號
        str_eqid = ""
        n = 0
        M = 1                               '得到的str_eqid 用與excel
        For M = 0 To ListSbbh.ListCount - 1
            If ListSbbh.Selected(M) = True Then
                str_eqid = str_eqid & Trim(ListSbbh.List(M))
                If n < ListSbbh.SelCount Then
                    str_eqid = str_eqid
                End If
                n = n + 1
            End If
        Next M
         xlSheet.Cells(1, 4) = "EQ Down Top10 Report"
        xlSheet.Cells(2, 1) = "Date:"
        xlSheet.Cells(2, 2) = Format(DTPickerStart.Value, "yyyy-mm-dd") & "  07:30:00"
        xlSheet.Cells(2, 3) = "TO"
        xlSheet.Cells(2, 4) = Format(DTPickerEnd.Value + 1, "yyyy-mm-dd") & "  07:30:00"
        xlSheet.Cells(3, 1) = "Eqid:"
        xlSheet.Cells(3, 2) = str_eqid
        
        xlSheet.Cells(4, 1) = "Bug Poenomenon"
        xlSheet.Cells(5, 1) = "Quantity"
        
        rsgzxx.MoveFirst
        
        line = 4
        Do While Not rsgzxx.EOF
            xlSheet.Cells(4, line).Value = rsgzxx("poenomenon").Value
            xlSheet.Cells(5, line).Value = rsgzxx("quantity").Value
            
            line = line + 1
            rsgzxx.MoveNext
        Loop
    End If     xlBook.SaveAs FileName:=savepath, FileFormat:=xlNormal, _
    PassWord:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
    CreateBackup:=False
    xlBook.Saved = True   '保存到Excel
    MsgBox "保存成功！", vbOKOnly, "信息"
    '結束EXcel進程
    xlApp.Quit  '不要此句也可以結束進程, 如果加上此句則出現提示是否保存
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
errhandler:
    
    Exit Sub
    
End Sub

Answer 8

Dim App As New Excel.Application
    Dim WorkBook As New Excel.WorkBook
    App.Visible = True
    Set WorkBook = App.Workbooks.Add注意要在工程中点应用然后选择Microsoft Excel X.0

Answer 9

我这里有一个程序，提供一个如何创建一个Excel表，以及如何快速的将数据导入到Excel表中,该程序的代码我已调试好，可以拿过来直接运行。
说明：
1、我以SQL2000数据库中的Northwind数据库为例
2、这一句话你需要改strCn = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=Northwind;Data Source=VIT-7"，这是我机器的数据库连接地址，你只要把它改成你的数据库连接地址就可以了。下面的把代码给你在新工程里的窗体:
Dim strCn As String
Dim strSQL As StringPrivate Sub Command1_Click()
strSQL = "select * from products"
strCn = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=Northwind;Data Source=VIT-7"
ExporToExcel strSQL, strCn
End Sub
在标准模块里添加如下代码：
'VB6 中将数据导出到 Excel 提速之法
Public Function ExporToExcel(strOpen As String, strCn As String)
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
'& 名称：ExporToExcel
'& 功能：导出数据到EXCEL
'& 用法：ExporToExcel(sql查询字符串)
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
Dim adoRs As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
    
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
    With adoRs
        If .State = 1 Then
            .Close
        End If
        .ActiveConnection = strCn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strOpen
        .Open
    End With
'    adoRs.Open strOpen, strCn, adOpenDynamic, adLockOptimistic
    With adoRs
        If .RecordCount < 1 Then
            MsgBox ("没有记录!")
            Exit Function
        End If
        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.Count
    End With
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlApp.Visible = True
    
    '添加查询语句，导入EXCEL数据
    Set xlQuery = xlSheet.QueryTables.Add(adoRs, xlSheet.Range("a1"))
    
    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With
    
    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh
    
    With xlSheet
        With .Range(.Cells(1, 1), .Cells(1, Icolcount))
        '设标题为黑体字
        .Font.Name = "黑体"
        '标题字体加粗
        .Font.Bold = True
        '设定第一行颜色
        .Interior.Color = &HC0FFC0
        End With
        With .Range(.Cells(2, 1), .Cells(Irowcount + 1, 1))
        .Font.Name = "宋体"
        .Interior.Color = &H80FFFF
        '设表格边框样式
        End With
    End With
    
    With xlSheet.PageSetup
        .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称："   ' & Gsmc
        .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
        .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
        .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
        .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
        .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
    End With
    
    xlApp.Application.Visible = True
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing
End Function