- Private Function FunImpExcel(ByVal strFilePath As String) As Integer
- 'Excel文件格式
- '第一行為表名,第二行為列名,其余行均為數(shù)據(jù)
- On Error GoTo hErr
- Dim objConn As New ADODB.Connection
- Dim objRS As New ADODB.Recordset
-
- If Dir(strFilePath) = "" Then
- MsgBox "文件不存在" , vbCritical, "錯(cuò)誤"
- Exit Function
- End If
- '定義Excel對(duì)象
- Dim xlsApp As Object
- Dim xlsWb As Object
- Dim xlsWs As Object
-
- Set xlsApp = CreateObject("Excel.Application") '建立excel對(duì)象
- Set xlsWb = xlsApp.Workbooks.Open(strFilePath) '要打開的文檔路徑
- Set xlsWs = xlsWb.Worksheets(1) '選工作表,有多張表時(shí),可以參考此,變換序號(hào)指定不同的表
-
- xlsWs.Activate
- xlsApp.Visible = false '隱藏,否則會(huì)在界面顯示出來
- 'Excel表格的行數(shù)和列數(shù)
- Dim iRowCnt As Integer
- Dim iColCnt As Integer
- iRowCnt = xlsWs.UsedRange.Rows.Count '這個(gè)并不完全準(zhǔn)確,在操作數(shù)據(jù)時(shí)要設(shè)置退出條件
- iColCnt = xlsWs.UsedRange.Columns.Count'這個(gè)并不完全準(zhǔn)確,在操作數(shù)據(jù)時(shí)要設(shè)置退出條件
- '下面要根據(jù)具體的表格情況決定,這里前面兩行是表名和列名
- If iRowCnt <= 2 Then
- MsgBox "沒有需要導(dǎo)入的明細(xì)數(shù)據(jù)" , vbCritical, "錯(cuò)誤"
- GoTo hErr
- End If
- '從第3行開始是明細(xì)數(shù)據(jù)
- For i = 3 To iRowCnt
- '設(shè)置退出條件
- If Trim$(xlsWs.Cells(i, 3).Value) = "" Then
- mdlPub.debug_print "on date found anymore:" & i
- Exit For
- End If
- '第一條數(shù)據(jù)時(shí),先打開數(shù)據(jù)庫,這里是access
- if 3 = i then
- '數(shù)據(jù)庫訪問操作可以封裝成一個(gè)公共的函數(shù)或過程
- Dim strConn as String
- strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=true;Data Source=test.mdb"
- objConn.CursorLocation = adUseClient
- objConn.Open strConn
- strSQL = "select * from [要導(dǎo)入的表名] where 1=2 "
- objRS.CursorLocation = adUseClient
- objRS.Open strSQL, objConn, adOpenKeyset, adLockOptimistic
- End if
- '新增一條記錄,注意各個(gè)字段的數(shù)據(jù)類型匹配問題,
- '最好全部統(tǒng)一先轉(zhuǎn)化為字符串,再轉(zhuǎn)化為對(duì)應(yīng)的類型
- objRS.AddNew
- objRS.Fields("數(shù)據(jù)庫列名1") = Trim(CStr(xlsWs.Cells(i, 1).Value))
- objRS.Fields("數(shù)據(jù)庫列名2") = Trim(CStr(xlsWs.Cells(i, 2).Value))
- '.....
- objRS.Fields("數(shù)據(jù)庫列名n") = CLng(Trim(CStr(xlsWs.Cells(i, n).Value)))
-
- '如果Excel列名與要導(dǎo)入的數(shù)據(jù)庫列能按順序一一對(duì)應(yīng),
- '則可以按以下方式,但要解決不同字段的數(shù)據(jù)格式匹配問題,比較麻煩
- 'For j = 0 To RS.Fields.Count - 1
- ' RS.Fields(j) = Trim(CStr(xlsWs.Cells(i, 1).Value))
- 'Next
-
- '更新到數(shù)據(jù)庫
- objRS.Update
- Next i
-
- objRS.Close
- objConn.Close
- Set objRS = Nothing
- Set objConn = Nothing
-
- xlsWb.Close '關(guān)閉excel文件
- xlsApp.Quit '退出excel
-
- Set xlsWs = Nothing
- Set xlsWb = Nothing
- Set xlsApp = Nothing
- FunImpExcel = 0'成功則返回0
-
- Exit Function
- hErr:
- ImpExcelCertDtl = -1 '失敗則返回1
- If Not (xlsWb Is Nothing) Then xlsWb.Close '關(guān)閉文件
- If Not (xlsApp Is Nothing) Then xlsApp.Quit
-
- Set xlsWs = Nothing
- Set xlsWb = Nothing
- Set xlsApp = Nothing
- MsgBox "文件導(dǎo)入失敗" , vbCritical, "錯(cuò)誤"
-
- End Function
對(duì)于一個(gè)Excel文件中多個(gè)表格的情況,可以循環(huán)逐一導(dǎo)入。
為了方便,對(duì)于excel對(duì)象的定義可以明確一些,這樣能自動(dòng)彈出提示,方便編碼。
如:
- Dim xlsApp As New Excel.Application
- Dim xlsWb As Excel.Workbook
- Dim xlsWs As Excel.Worksheet
但這樣定義時(shí)需要在工程中引入excel組件。
====================================================
將數(shù)據(jù)導(dǎo)出至Excel
- '-----------------
- '從數(shù)據(jù)從數(shù)據(jù)庫導(dǎo)出至excel,并彈出保存文件對(duì)話框
- '-------------------
- Private Function FunExpExcel()
-
- On Error GoTo hErr
- '注意引用excel組件,也可以直接定義為對(duì)象object
- Dim xlsApp As New Excel.Application
- Dim xlsWb As Excel.Workbook
- Dim xlsWs As Excel.Worksheet
- Dim strFilePath As String
- Dim strFileNm As String
- Dim iColIdx As Integer
-
- Dim objTmp As Object
-
- '創(chuàng)建excel
- Set xlsApp = CreateObject("Excel.Application")
- xlsApp.Visible = False
- xlsApp.SheetsInNewWorkbook = 1 '定義表格個(gè)數(shù)
- '新增一張表格, 這里可以增加多張表
- Set xlsWb = xlsApp.Workbooks.Add
- '指定sheet,指定第一張,如果有多張,可以具體指定哪一個(gè)
- Set xlsWs = xlsWb.Worksheets(1)
-
- 'xlsApp.Visible = False
- xlsWs.Activate
- xlsWs.Select
- '第一行為標(biāo)題
- xlsWs.Cells(1, 1).Value = "表格標(biāo)題"
- '第二行為列名,第一列列名“序號(hào)”
- xlsWs.Cells(2, 1).Value = "序號(hào)"
- ....
- xlsWs.Cells(2, n).Value = "序號(hào)"
- '如果是datagrid,可以直接用對(duì)應(yīng)的列名
- 'For iColIdx = 0 To Me.grdQryInst.Columns.Count - 1
- ' xlsWs.Cells(2, iColIdx + 2).Value = Me.datagrid1.Columns(iColIdx).Caption
- 'Next
- '設(shè)置第一列序號(hào)為數(shù)字格式
- xlsWs.Columns("A:A").NumberFormatLocal = "0_ "
-
- '設(shè)置其它列為文本格式,函數(shù)NumToChar26能將數(shù)字轉(zhuǎn)化為對(duì)應(yīng)的excel列名,如2->B,3->C,自已實(shí)現(xiàn)
- 'xlsWs.Columns(NumToChar26(2) & ":" & NumToChar26(Me.datagrid1.Columns.Count)).NumberFormatLocal = "@"
-
- '----這里打開數(shù)據(jù)庫,查詢數(shù)據(jù)略,自己實(shí)現(xiàn),如果是datagrid,則可以按下面的方法
- 'Dim RS As ADODB.Recordset
- 'Set RS = Me.datagrid1.DataSource
- '從第三行開始寫明細(xì)數(shù)據(jù)
- RS.MoveFirst
- For iRowIdx = 0 To RS.RecordCount - 1
- xlsWs.Cells(iRowIdx + 3, 1).Value = CStr(iRowIdx + 1)
- '對(duì)第一行,按順序逐列寫單元格
- For iColIdx = 0 To RS.Fields.Count - 1
- xlsWs.Cells(iRowIdx + 3, iColIdx + 2).Value = RS.Fields(iColIdx).Value
- Next
- RS.MoveNext
- Next
- '-----寫完數(shù)據(jù),下面設(shè)置導(dǎo)出excel格式
- '標(biāo)題格式設(shè)置
- Set objTmp = xlsWs.Range(xlsWs.Cells(1, 1), xlsWs.Cells(1, iColIdx + 2 - 1))
- objTmp.Merge '合并單元格
- '標(biāo)題排版
- With objTmp
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- End With
- With objTmp.Font
- .Name = "宋體"
- .Size = 18
- End With
-
- '第2行開始,設(shè)置邊框,字體與標(biāo)題不同
- Set objTmp = xlsApp.Range(xlsWs.Cells(2, 1), xlsWs.Cells(iRowIdx + 3 - 1, iColIdx + 2 - 1))
- With objTmp.Font
- .Name = "宋體"
- .Size = 10
- .Underline = xlUnderlineStyleNone
- .ColorIndex = xlAutomatic
- End With
- objTmp.Borders(xlDiagonalDown).LineStyle = xlNone
- objTmp.Borders(xlDiagonalUp).LineStyle = xlNone
- With objTmp.Borders(xlEdgeLeft)
- .LineStyle = xlContinuous
- .Weight = xlThin
- .ColorIndex = xlAutomatic
- End With
- With objTmp.Borders(xlEdgeTop)
- .LineStyle = xlContinuous
- .Weight = xlThin
- .ColorIndex = xlAutomatic
- End With
- With objTmp.Borders(xlEdgeBottom)
- .LineStyle = xlContinuous
- .Weight = xlThin
- .ColorIndex = xlAutomatic
- End With
- With objTmp.Borders(xlEdgeRight)
- .LineStyle = xlContinuous
- .Weight = xlThin
- .ColorIndex = xlAutomatic
- End With
- With objTmp.Borders(xlInsideVertical)
- .LineStyle = xlContinuous
- .Weight = xlThin
- .ColorIndex = xlAutomatic
- End With
- With objTmp.Borders(xlInsideHorizontal)
- .LineStyle = xlContinuous
- .Weight = xlThin
- .ColorIndex = xlAutomatic
- End With
-
- '設(shè)置列寬,自動(dòng)擴(kuò)展
- For iColIdx = 1 To Me.grdQryInst.Columns.Count + 1
- xlsWs.Columns(NumToChar26(iColIdx) & ":" & NumToChar26(iColIdx)).EntireColumn.AutoFit
- Next
-
- '彈出保存文件對(duì)話框,要在窗體上增加commondialog控件,控件命名dlgFile
- Me.dlgFile.DialogTitle = "保存至"
- Me.dlgFile.Flags = &H200
- Me.dlgFile.DefaultExt = ".xls"
-
- Me.dlgFile.Filter = "Excel數(shù)據(jù)文件 *.xls|*.xls" '過濾器
- Me.dlgFile.InitDir = App.Path
- Me.dlgFile.FileName = strFileNm & ".xls"
- Me.dlgFile.ShowSave
-
- If Err <> 32755 Then strFilePath = dlgFile.FileName
- If "" <> strFilePath Then
- xlsWb.SaveAs strFilePath
- Else
- mdlPub.ShowInfo "文件未保存"
- End If
-
- xlsWb.Close
- xlsApp.Quit
- Set xlsWs = Nothing
- Set xlsWb = Nothing
- Set xlsApp = Nothing
- FunExpExcel = 0 '成功則返回0
- mdlPub.ShowInfo "已保存至" & strFilePath
- Exit Sub
- hErr:
- FunExpExcel = -1'失敗則返回1
- If Err.Number <> 0 Then mdlPub.ShowErrMsg "導(dǎo)出錯(cuò)"
- If Not (xlsWb Is Nothing) Then Set xlsWs = Nothing
- If Not (xlsWb Is Nothing) Then
- xlsWb.Close
- Set xlsWb = Nothing
- End If
- If Not (xlsWb Is Nothing) Then
- xlsApp.Quit
- Set xlsApp = Nothing
- End If
-
- End Function
=================================
h注意,在使用VB操作 excel過程中,對(duì)于excel對(duì)象的引用都要用到本地定義的excel三個(gè)變量xlsApp,xlsWb,xlsWs之一做前綴,否則, 會(huì)出現(xiàn)殘留EXCEL進(jìn)程的情況,下次操作EXCEL時(shí)會(huì)報(bào)錯(cuò)。原因是沒有加本地定義的變量做前綴,而使用了EXCEl的全局變量形式,xlsWb.Close, xlsApp.Quit語句只是退出局部EXCEL,無法退出全局EXCEL。
本站僅提供存儲(chǔ)服務(wù),所有內(nèi)容均由用戶發(fā)布,如發(fā)現(xiàn)有害或侵權(quán)內(nèi)容,請(qǐng)
點(diǎn)擊舉報(bào)。