Private Sub CmdJoinExcel_Click() '
Dim xlsApp As Object
Dim xlsBook As Object
Dim xlsSheet As Object
Dim xlsApp As New Excel.Application
On Error Resume Next ' 改變錯誤陷阱
Set xlsApp = GetObject(App.Path, "et.Application")
If Err Then
Err.Clear '清除 Err 物件欄位
Set xlsApp = CreateObject("et.Application")
If Err Then
Exit Sub ' 退出程式，以避免進入錯誤處理程式
End If
End If
xlsApp.Visible = True
Set xlsBook = xlsApp.Workbooks.Add LX = (ComLX.Text)
Select Case LX
Case Is = 1
Set xlsSheet = xlsBook.Worksheets(1) '設定作業表1
Cells(1, 1) = "基本引數": Cells(2, 1) = "名稱": Cells(2, 2) = "開式深溝球優化引數": Cells(3, 1) = "系列"
Case Is = 2
Set xlsSheet = xlsBook.Worksheets(2) '設定作業表2
Cells(1, 1) = "基本引數": Cells(2, 1) = "名稱": Cells(2, 2) = "密封深溝球優化引數": Cells(3, 1) = "系列"
Case Is = 3
Set xlsSheet = xlsBook.Worksheets(3) '設定作業表3
Cells(1, 1) = "基本引數": Cells(2, 1) = "名稱": Cells(2, 2) = "帶防塵蓋深溝球優化引數": Cells(3, 1) = "系列"
End Select
xlsApp.Save '保存作業簿
xlsBook.Close '關閉作業薄檔案
xlsApp.Quit '結束excel物件
Set xlsApp = Nothing '釋放xlapp物件得記憶體空間
Set xlsBook = Nothing
Set xlsSheet = Nothing
End Sub
大神，現在的問題是第一次可以給excel賦值，第二次就變成空的了，不能賦值，求解答，十分感謝啊！
uj5u.com熱心網友回復：
樓主，火星來的吧？你這代碼在地球上能運行？uj5u.com熱心網友回復：
Private Sub Command1_Click()
Dim xlsApp As Object
Dim xlsBook As Object
Dim xlsSheet As Object
Dim xlscells As Object
On Error Resume Next ' 改變錯誤陷阱
Set xlsApp = GetObject(App.Path, "excel.Application")
If Err Then
Err.Clear '清除 Err 物件欄位
Set xlsApp = CreateObject("excel.Application")
If Err Then
Exit Sub ' 退出程式，以避免進入錯誤處理程式
End If
End If
xlsApp.Visible = True
Set xlsBook = xlsApp.Workbooks.Add
LX = Val(Text1.Text)
Set xlsSheet = xlsBook.Worksheets(1) '設定作業表1
cells(1, 1) = LX
xlsApp.Save '保存作業簿
xlsBook.Close '關閉作業薄檔案
xlsApp.Quit '結束excel物件
Set xlsApp = Nothing '釋放xlapp物件得記憶體空間
Set xlsBook = Nothing
Set xlsSheet = Nothing
End Sub
大神，現在的代碼你看看吧，麻煩了啊！
uj5u.com熱心網友回復：
'前綴不能省。你應該把對Excel的參考去掉，原先的陳述句就報錯了。'
xlsSheet.cells(1, 1) = LX
'物件關閉/釋放必須按從小到大的次序來！'
Set xlsSheet = Nothing
xlsApp.Save '保存作業簿
xlsBook.Close '關閉作業薄檔案
Set xlsBook = Nothing
xlsApp.Quit '結束excel物件
Set xlsApp = Nothing '釋放xlapp物件得記憶體空間
uj5u.com熱心網友回復：
好吧，再來一個例子：Option Explicit
Sub Test()
On Error Resume Next
Dim xlsApp As Excel.Application, xlsBook As Excel.Workbook
Dim bCreated As Boolean
''首先獲取已經打開的Excel物件
Set xlsApp = GetObject(, "Excel.Application")
If xlsApp Is Nothing Then
''如果Excel沒有打開，創建一個新的Excel物件
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = True
bCreated = True ''標記這個excel物件是我創建的
End If
''設定作業簿物件
Set xlsBook = xlsApp.Workbooks.Add
''檢查作業表的數量,保證至少有3張表
With xlsBook.Worksheets
If .Count < 3 Then
Do While .Count < 3
.Add ''回圈添加新作業表
Loop
End If
End With
''開始填充資料
With xlsBook.Worksheets(1) ''第1張表
.Cells(1, 1) = "基本引數"
.Cells(2, 1) = "名稱"
.Cells(2, 2) = "開式深溝球優化引數"
.Cells(3, 1) = "系列"
End With
With xlsBook.Worksheets(2) ''第2張表
.Cells(1, 1) = "基本引數"
.Cells(2, 1) = "名稱"
.Cells(2, 2) = "密封深溝球優化引數"
.Cells(3, 1) = "系列"
End With
With xlsBook.Worksheets(3) ''第3張表
.Cells(1, 1) = "基本引數"
.Cells(2, 1) = "名稱"
.Cells(2, 2) = "帶防塵蓋深溝球優化引數"
.Cells(3, 1) = "系列"
End With
xlsBook.Save ''保存作業簿
xlsBook.Close ''關閉作業簿
Set xlsBook = Nothing ''卸載作業簿物件
If bCreated Then xlsApp.Quit ''如果是自己創建的excel物件則關閉
Set xlsApp = Nothing ''卸載Excel物件
End Sub
..
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/76818.html
標籤：VB基礎類
下一篇：VBA中運行這段 Do While Range("A1:A65536") <> "" 時 提示運行錯誤'13' 型別不匹配