VB操作EXCEL文件大全

Set xlBook = xlApp.Workbooks.Open(strD1)
Set xlSheet = xlBook.Worksheets(1)

With xlSheet
.Range("F6").Value = strTmp1(1)
.Range("H6").Value = strTmp1(2)
.Range("F7").Value = CStr(Date)
.Range("E10").Value = strTmp1(9)
.Range("A15").Value = "To: " + strTmp1(8)
.Range("B26").Value = strTmp1(4) + "PACKAGES"
.Range("B27").Value = strTmp1(5) + "KGS"
.Range("B28").Value = strTmp1(6) + "KGS"
.Range("B29").Value = strTmp1(7) + "M3"
End With

intCol = 1
intRow = 21

For i1 = 1 To colTmp1.Count
strArray1 = colTmp1.Item(i1)
With xlSheet
.Cells(intRow,1).Value = strArray1(2)
.Cells(intRow,2).Value = strArray1(5)
.Cells(intRow,4).Value = strArray1(6)
.Cells(intRow,5).Value = strArray1(1)
.Cells(intRow,6).Value = strArray1(3)
.Cells(intRow,7).Value = strArray1(4)
.Cells(intRow,8).Value = strArray1(7)
.Cells(intRow,9).Value = strArray1(9)
intRow = intRow + 1
xlApp.ActiveSheet.Rows(intRow).Insert
.Cells(intRow,1).Value = strArray1(8)
intRow = intRow + 1
xlApp.ActiveSheet.Rows(intRow).Insert
End With
intRow = intRow + 1
xlApp.ActiveSheet.Rows(intRow).Insert
Next i1

xlApp.Visible = True
xlBook.Save
' xlBook.Close
Set xlSheet = Nothing
Set xlBook = Nothing
' xlApp.Quit

' tmp1 = Shell(strName,1)

' hWndDesk = GetDesktopWindow()
' r = ShellExecute(hWndDesk,"Open",strName,vbNullString,0&,1)

End Sub

--------------------------------------

Dim xlApp As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet

Public Sub exportExcel()
'
Dim strA1() As String,strA2() As String,strTmp1 As String,strDATE As String,strName As String,strValue As String
Dim intFieldLength As Integer,i1 As Integer,i2 As Integer,lngCount As Long
Dim rs1 As DAO.Recordset

strTmp1 = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1,K1,L1,M1,N1,O1,P1,Q1,R1,S1,T1,U1,V1,W1,X1,Y1,Z1,AA1,AB1,AC1,AD1,AE1,AF1,AG1,AH1,AI1,AJ1,AK1,AL1,AM1,AN1,AO1,AP1,AQ1,AR1,AS1,AT1,AU1,AV1,AW1,AX1,AY1,AZ1,BA1,BB1,BC1,BD1,BE1,BF1,BG1,BH1,BI1,BJ1,BK1,BL1,BM1,BN1,BO1,BP1,BQ1,BR1,BS1,BT1,BU1,BV1,BW1,BX1,BY1,BZ1,CA1,CB1,CC1,CD1,CE1,CF1,CG1,CH1,CI1,CJ1,CK1,CL1,CM1,CN1,CO1,CP1,CQ1,CR1,CS1,CT1,CU1,CV1,CW1,CX1,CY1,CZ1"
strA1 = Split(strTmp1,",")

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add

strDATE = CStr(Format(Date,"YYYY-MM-DD"))
Me.CommonDialog1.DefaultExt = "xls"
Me.CommonDialog1.Filename = "帐单输出" + strDATE + ".xls"
Me.CommonDialog1.Filter = "EXCEL FILE(*.xls)|*.xls"
Me.CommonDialog1.ShowSave

strName = Me.CommonDialog1.Filename
xlBook.SaveAs strName
Set xlBook = xlApp.Workbooks.Open(strName)
Set xlSheet = xlBook.Worksheets(1)

strsql = "SELECT * FROM HEADCOST1; "
Set rs1 = CurrentDb.OpenRecordset(strsql)
rs1.MoveLast
Debug.Print rs1.RecordCount
lngCount = rs1.RecordCount
intFieldLength = rs1.Fields.Count
' Debug.Print intFieldLength
Debug.Print intFieldLength
strA2() = Split(splitTable("HEADCOST1"),")
Debug.Print UBound(strA2)

With xlSheet
For i1 = 0 To intFieldLength - 1
Debug.Print i1
Debug.Print strA1(i1)
.Range(strA1(i1)).Value = getZValue(strA2(i1))
Next i1
End With

If rs1.RecordCount <> 0 Then
rs1.MoveFirst
For i1 = 1 To lngCount
For i2 = 1 To rs1.Fields.Count
If IsNull(rs1(i2 - 1)) Then
strValue = " "
Else
strValue = rs1(i2 - 1).Value
End If
xlSheet.Cells(i1 + 1,i2) = strValue
Next i2
rs1.MoveNext
Next i1
rs1.MoveFirst
Else
MsgBox "未读取到数据",vbCritical,"错误"
End If

xlBook.Save
xlBook.Close

Set xlSheet = Nothing
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing

rs1.Close
Set rs1 = Nothing
End Sub

--------------------------------

Private Sub Command1_Click()
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add

Dim strDate As String,strValue As String
strDate = CStr(Format(Date,"yyyy-mm-dd"))
Me.CommonDialog1.DefaultExt = "xls"
Me.CommonDialog1.FileName = "SEND3B2" + strDate + ".xls"
Me.CommonDialog1.Filter = "EXCEL FILE(*.xls)|*.xls"
Me.CommonDialog1.ShowSave

strName = Me.CommonDialog1.FileName
Debug.Print strName
xlBook.SaveAs strName
Set xlBook = xlApp.Workbooks.Open(strName)
Set xlSheet = xlBook.Worksheets(1)
' For i1 = 0 To Me.DataGrid1.Columns.Count - 1
' xlSheet.Cells(1,i1 + 1) = Me.DataGrid1.Columns.Item(j).Caption
' Next i1
With xlSheet
.Range("A1").Value = "ORDERKEY"
.Range("B1").Value = "EXTERNORDERKEY"
.Range("C1").Value = "MM"
.Range("D1").Value = "QTY"
.Range("E1").Value = "PRODUCTDESP"
.Range("F1").Value = "DIVISION"
.Range("G1").Value = "MOQ"
.Range("H1").Value = "OVERPACKQTY"
.Range("I1").Value = "OVERPACK ?"
.Range("J1").Value = "CTNQTY"
.Range("K1").Value = "OPCTNQTY"
.Range("L1").Value = "CTN_PALLET"
.Range("M1").Value = "PALLETNO"
.Range("N1").Value = "PALLETWEIGHT"
.Range("O1").Value = "PALLETVOLUME"
.Range("P1").Value = "PALLETLENGTH"
.Range("Q1").Value = "PALLETWIDTH"
.Range("R1").Value = "PALLETHIGH"
.Range("S1").Value = "DELIVERYDATE"
.Range("T1").Value = "CONSIGNEEKEY"
.Range("U1").Value = "C_COUNTRY"
.Range("V1").Value = "BILLTOKEY"
.Range("W1").Value = "INCOTERM"
.Range("X1").Value = "STATUS"
.Range("Y1").Value = "INTERMODALVEHICLE"
.Range("Z1").Value = "ORDERGROUP"
.Range("AA1").Value = "HAWB"
.Range("AB1").Value = "REQSHIPDATE"
.Range("AC1").Value = "RELEASEDDATE"
.Range("AD1").Value = "C_COMPANY"
End With
If Me.Adodc1.Recordset.RecordCount <> 0 Then
Me.Adodc1.Recordset.MoveFirst
For i1 = 1 To Me.Adodc1.Recordset.RecordCount
For i2 = 1 To Me.Adodc1.Recordset.Fields.Count
If IsNull(Me.Adodc1.Recordset.Fields(i2 - 1)) Then
strValue = " "
Else
strValue = Me.Adodc1.Recordset.Fields(i2 - 1).Value ': Debug.Print strValue
End If
xlSheet.Cells(i1 + 1,i2) = strValue
Next i2
Me.Adodc1.Recordset.MoveNext
Next i1
Me.Adodc1.Recordset.MoveFirst
Else
MsgBox "请先查询数据","错误"
End If

xlBook.Save

xlBook.Close
Set xlSheet = Nothing
Set xlBook = Nothing
' xlApp.Visible = True
xlApp.Quit
Set xlApp = Nothing
End Sub

----------------------------

用VB操作Excel(VB6.0)(整理)

首先创建Excel对象，使用ComObj:
Dim ExcelID as Excel.Application
Set ExcelID as new Excel.Application

1)显示当前窗口：
ExcelID.Visible:=True;
2)更改Excel标题栏：
ExcelID.Caption:='应用程序调用MicrosoftExcel';
3)添加新工作簿：
ExcelID.WorkBooks.Add;
4)打开已存在的工作簿：
ExcelID.WorkBooks.Open('C:\Excel\Demo.xls');
5)设置第2个工作表为活动工作表：
ExcelID.WorkSheets[2].Activate;
或ExcelID.WorkSheets['Sheet2'].Activate;
6)给单元格赋值：
ExcelID.Cells[1,4].Value:='第一行第四列';
7)设置指定列的宽度（单位：字符个数），以第一列为例：
ExcelID.ActiveSheet.Columns[1].ColumnsWidth:=5;
8)设置指定行的高度（单位：磅）（1磅＝0.035厘米），以第二行为例：
ExcelID.ActiveSheet.Rows[2].RowHeight:=1/0.035;//1厘米
9)在第8行之前插入分页符：
ExcelID.WorkSheets[1].Rows[8].PageBreak:=1;
10)在第8列之前删除分页符：
ExcelID.ActiveSheet.Columns[4].PageBreak:=0;
11)指定边框线宽度：
ExcelID.ActiveSheet.Range['B3:D4'].Borders[2].Weight:=3;
1-左 2-右 3-顶4-底 5-斜(\) 6-斜(/)
12)清除第一行第四列单元格公式：
ExcelID.ActiveSheet.Cells[1,4].ClearContents;
13)设置第一行字体属性：
ExcelID.ActiveSheet.Rows[1].Font.Name:='隶书';
ExcelID.ActiveSheet.Rows[1].Font.Color :=clBlue;
ExcelID.ActiveSheet.Rows[1].Font.Bold :=True;
ExcelID.ActiveSheet.Rows[1].Font.UnderLine:=True;
14)进行页面设置：
a.页眉：
ExcelID.ActiveSheet.PageSetup.CenterHeader:='报表演示';
b.页脚：
ExcelID.ActiveSheet.PageSetup.CenterFooter:='第&P页';
c.页眉到顶端边距2cm：
ExcelID.ActiveSheet.PageSetup.HeaderMargin:=2/0.035;
d.页脚到底端边距3cm：
ExcelID.ActiveSheet.PageSetup.HeaderMargin:=3/0.035;
e.顶边距2cm：
ExcelID.ActiveSheet.PageSetup.TopMargin:=2/0.035;
f.底边距2cm：
ExcelID.ActiveSheet.PageSetup.BottomMargin:=2/0.035;
g.左边距2cm：
ExcelID.ActiveSheet.PageSetup.LeftMargin:=2/0.035;
h.右边距2cm：
ExcelID.ActiveSheet.PageSetup.RightMargin:=2/0.035;
i.页面水平居中：
ExcelID.ActiveSheet.PageSetup.CenterHorizontally:=2/0.035;
j.页面垂直居中：
ExcelID.ActiveSheet.PageSetup.CenterVertically:=2/0.035;
k.打印单元格网线：
ExcelID.ActiveSheet.PageSetup.PrintGridLines:=True;
15)拷贝操作：
a.拷贝整个工作表：
ExcelID.ActiveSheet.Used.Range.Copy;
b.拷贝指定区域：
ExcelID.ActiveSheet.Range['A1:E2'].Copy;
c.从A1位置开始粘贴：
ExcelID.ActiveSheet.Range.['A1'].PasteSpecial;
d.从文件尾部开始粘贴：
ExcelID.ActiveSheet.Range.PasteSpecial;
16)插入一行或一列：
a.ExcelID.ActiveSheet.Rows[2].Insert;
b.ExcelID.ActiveSheet.Columns[1].Insert;
17)删除一行或一列：
a.ExcelID.ActiveSheet.Rows[2].Delete;
b.ExcelID.ActiveSheet.Columns[1].Delete;
18)打印预览工作表：
ExcelID.ActiveSheet.PrintPreview;
19)打印输出工作表：
ExcelID.ActiveSheet.PrintOut;
20)工作表保存：
IfnotExcelID.ActiveWorkBook.Savedthen
ExcelID.ActiveSheet.PrintPreview
Endif
21)工作表另存为：
ExcelID.SaveAs('C:\Excel\Demo1.xls');
22)放弃存盘：
ExcelID.ActiveWorkBook.Saved:=True;
23)关闭工作簿：
ExcelID.WorkBooks.Close;
24)退出Excel：
ExcelID.Quit;
25)设置工作表密码:
ExcelID.ActiveSheet.Protect"123",DrawingObjects:=True,Contents:=True,Scenarios:=True
26)EXCEL的显示方式为最大化
ExcelID.Application.WindowState=xlMaximized
27)工作薄显示方式为最大化
ExcelID.ActiveWindow.WindowState=xlMaximized
28)设置打开默认工作薄数量
ExcelID.SheetsInNewWorkbook=3
29)'关闭时是否提示保存(true保存；false不保存)
ExcelID.DisplayAlerts=False
30)设置拆分窗口,及固定行位置
ExcelID.ActiveWindow.SplitRow=1
ExcelID.ActiveWindow.FreezePanes=True
31)设置打印时固定打印内容
ExcelID.ActiveSheet.PageSetup.PrintTitleRows="$1:$1"
32)设置打印标题
ExcelID.ActiveSheet.PageSetup.PrintTitleColumns=""
33)设置显示方式(分页方式显示)
ExcelID.ActiveWindow.View=xlPageBreakPreview
34)设置显示比例
ExcelID.ActiveWindow.Zoom=100
35)让Excel响应DDE请求
Ex.Application.IgnoreRemoteRequests=False

用VB操作EXCEL示例代码
Private Sub Command3_Click()
On Error GoTo err1
Dim i As Long
Dim j As Long
Dim objExl As Excel.Application '声明对象变量
Me.MousePointer=11 '改变鼠标样式
Set objExl=New Excel.Application'初始化对象变量
objExl.SheetsInNewWorkbook=1 '将新建的工作薄数量设为1
objExl.Workbooks.Add'增加一个工作薄
objExl.Sheets(objExl.Sheets.Count).Name="book1" '修改工作薄名称
objExl.Sheets.Add,objExl.Sheets("book1")‘增加第二个工作薄在第一个之后
objExl.Sheets(objExl.Sheets.Count).Name="book2"
objExl.Sheets.Add,objExl.Sheets("book2")‘增加第三个工作薄在第二个之后
objExl.Sheets(objExl.Sheets.Count).Name="book3"

objExl.Sheets("book1").Select '选中工作薄<book1>
For i=1 To 50'循环写入数据
For j=1 To 5
If i=1 Then
objExl.Selection.NumberFormatLocal="@" '设置格式为文本
objExl.Cells(i,j)="E"&i&j
Else
objExl.Cells(i,j)=i&j
EndIf
Next
Next
objExl.Rows("1:1").Select '选中第一行
objExl.Selection.Font.Bold=True '设为粗体
objExl.Selection.Font.Size=24 '设置字体大小
objExl.Cells.EntireColumn.AutoFit '自动调整列宽
objExl.ActiveWindow.SplitRow=1 '拆分第一行
objExl.ActiveWindow.SplitColumn=0 '拆分列
objExl.ActiveWindow.FreezePanes=True '固定拆分objExl.ActiveSheet.PageSetup.PrintTitleRows="$1:$1" '设置打印固定行
objExl.ActiveSheet.PageSetup.PrintTitleColumns=""'打印标题objExl.ActiveSheet.PageSetup.RightFooter="打印时间:"&_
Format(Now,"yyyy年mm月dd日hh:MM:ss")
objExl.ActiveWindow.View=xlPageBreakPreview'设置显示方式
objExl.ActiveWindow.Zoom=100 '设置显示大小
'给工作表加密码
objExl.ActiveSheet.Protect"123",_
Contents:=True,Scenarios:=True
objExl.Application.IgnoreRemoteRequests=False
objExl.Visible=True '使EXCEL可见
objExl.Application.WindowState=xlMaximized'EXCEL的显示方式为最大化
objExl.ActiveWindow.WindowState=xlMaximized'工作薄显示方式为最大化
objExl.SheetsInNewWorkbook=3 '将默认新工作薄数量改回3个
Set objExl=Nothing'清除对象
Me.MousePointer=0 '修改鼠标
ExitSub
err1:
objExl.SheetsInNewWorkbook=3

objExl.DisplayAlerts=False '关闭时不提示保存
objExl.Quit'关闭EXCEL
objExl.DisplayAlerts=True '关闭时提示保存
Set objExl=Nothing
Me.MousePointer=0
End Sub

Dim excelfile As Excel.Application,excelwbook As Excel.Workbook,excelsheet As Excel.Worksheet

Private Sub ImportExcelData()
'
On Error GoTo Err_ImportExcelData
Dim strFile As String
Dim strB1() As String,intTmp1 As Integer

DoCmd.Runsql "DELETE * FROM APTmp "
Me.CommonDialog8.ShowOpen
strFile = Me.CommonDialog8.Filename

Debug.Print strFile
If strFile = "" Then
MsgBox "没有选择文件","错误"
Exit Sub
End If

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count
Debug.Print lastCol
Debug.Print lastRow

Debug.Print excelsheet.Cells(1,1)


strB1 = Split(strFile,"\")
intTmp1 = UBound(strB1)
strFile = strB1(intTmp1)
Debug.Print strFile

' If checkFileName(strFile) = True Then
' MsgBox "此文件名已经导入过,不可再导入","错误"
' Exit Sub
' End If

If intChange = 2 Then
Call ImportAPData2(strFile)
Else
Call ImportAPData(strFile)
End If

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing
MsgBox "EXCEL数据导入完成","提示"
Exit_ImportExcelData:
Exit Sub
Err_ImportExcelData:
MsgBox Err.Description
Resume Exit_ImportExcelData
End

Private Sub ImportAPData(strTmp1 As String)
'
Dim i2 As Long,strTmp2 As String,boolTmp1 As Boolean

For i2 = 2 To lastRow
Debug.Print excelsheet.Cells(i2,7)
If checkDN(Trim(CStr(excelsheet.Cells(i2,7))),"APT") = True Then

If checkRoute(Trim(CStr(excelsheet.Cells(i2,5)))) = False Then
strTmp2 = Trim(CStr(excelsheet.Cells(i2,1)))
boolTmp1 = True
Else
strTmp2 = "WBLP"
GoTo LOOP1
End If

If checkR8(Trim(CStr(excelsheet.Cells(i2,8)))) = 1 Then GoTo LOOP1

' 1 2 3 4 5 6 7 8 9
strsql = "INSERT INTO APTmp ( OrderType,CreateDate,GIdate,ShipTo,Route,OriginDoc,DeliveryNum,LOCATION,HAWB ) "
' strsql = strsql + "VALUES('" + Trim(CStr(excelsheet.Cells(i2,1))) + "',"
strsql = strsql + "VALUES('" + strTmp2 + "',"
strsql = strsql + "'" + Trim(CStr(excelsheet.Cells(i2,2))) + "',3))) + "',4))) + "',5))) + "',6))) + "',7))) + "',"
' If checkRoute(Trim(CStr(excelsheet.Cells(i2,5)))) = False Then
' strsql = strsql + "'" + Trim(CStr(excelsheet.Cells(i2,8))) + "') "
' Else
' strsql = strsql + "'" + addR8TSHAWB + "')"
'
' End If
' strsql = strsql + "'" + strTmp1 + "'" + ") "
If Trim(CStr(excelsheet.Cells(i2,9))) = "" Then
strsql = strsql + "'" + "R811" + "',"
Else
strsql = strsql + "'" + Trim(CStr(excelsheet.Cells(i2,9))) + "',"
End If
If boolTmp1 = True Then
strsql = strsql + "'" + Trim(CStr(excelsheet.Cells(i2,8))) + "') "
boolTmp1 = False
Else
strsql = strsql + "'" + addR8TSHAWB + "')"
boolTmp1 = False
GoTo LOOP1
End If
Debug.Print strsql
DoCmd.Runsql strsql
LOOP1:
strTmp2 = ""
boolTmp1 = False
End If
Next i2
Call ImportTAPData
End Sub
'INSERT INTO APTmp ( OrderType,HAWB )
'VALUES('1','1','1')

Private Sub ImportAPData2(strTmp1 As String)
'
Dim i2 As Long,10): Debug.Print excelsheet.Cells(i2,10))),12)))) = 1 Then GoTo LOOP1

' 1 2 3 4 5 6 7 8 9
strsql = "INSERT INTO APTmp ( OrderType," 2012-9-7 修改添加WBLP条款
strsql = strsql + "VALUES('" + strTmp2 + "',"
' strsql = strsql + "'" + Trim(CStr(excelsheet.Cells(i2,8))) + "',10))) + "',8))) + "') "
' Else
' strsql = strsql + "'" + addR8TSHAWB + "')"
'
' End If
' strsql = strsql + "'" + strTmp1 + "'" + ") "
' If Trim(CStr(excelsheet.Cells(i2,"
' Else
' strsql = strsql + "'" + Trim(CStr(excelsheet.Cells(i2,"
' End If
If boolTmp1 = True Then
strsql = strsql + "'" + Trim(CStr(excelsheet.Cells(i2,12))) + "') "
boolTmp1 = False
Else
strsql = strsql + "'" + addR8TSHAWB + "')"
boolTmp1 = False
GoTo LOOP1
End If
Debug.Print strsql
DoCmd.Runsql strsql
LOOP1:
strTmp2 = ""
boolTmp1 = False
End If
Next i2
Call ImportTAPData
End Sub

--------------------------

Private Sub Command3_Click()
On Error GoTo err1
Dim i As Long
Dim j As Long
Dim objExl As Excel.Application '声明对象变量
Me.MousePointer = 11 '改变鼠标样式
Set objExl = New Excel.Application '初始化对象变量
objExl.SheetsInNewWorkbook = 1 '将新建的工作薄数量设为1
objExl.Workbooks.Add '增加一个工作薄
objExl.Sheets(objExl.Sheets.Count).Name = "book1" '修改工作薄名称
objExl.Sheets.Add,objExl.Sheets("book1") '增加第二个工作薄在第一个之后
objExl.Sheets(objExl.Sheets.Count).Name = "book2"
objExl.Sheets.Add,objExl.Sheets("book2") '增加第三个工作薄在第二个之后
objExl.Sheets(objExl.Sheets.Count).Name = "book3"
objExl.Sheets("book1").Select '选中工作薄<book1>
For i = 1 To 50 '循环写入数据
For j = 1 To 5
If i = 1 Then
objExl.Selection.NumberFormatLocal = "@" '设置格式为文本
objExl.Cells(i,j) = " E " & i & j
Else
objExl.Cells(i,j) = i & j
End If
Next
Next
objExl.Rows("1:1").Select '选中第一行
objExl.Selection.Font.Bold = True '设为粗体
objExl.Selection.Font.Size = 24 '设置字体大小
objExl.Cells.EntireColumn.AutoFit '自动调整列宽
objExl.ActiveWindow.SplitRow = 1 '拆分第一行
objExl.ActiveWindow.SplitColumn = 0 '拆分列
objExl.ActiveWindow.FreezePanes = True '固定拆分
objExl.ActiveSheet.PageSetup.PrintTitleRows = "$1:$1" '设置打印固定行
objExl.ActiveSheet.PageSetup.PrintTitleColumns = "" '打印标题
objExl.ActiveSheet.PageSetup.RightFooter = "打印时间: " & _
Format(Now,"yyyy年mm月dd日 hh:MM:ss")
objExl.ActiveWindow.View = xlPageBreakPreview '设置显示方式
objExl.ActiveWindow.Zoom = 100 '设置显示大小
'给工作表加密码
objExl.ActiveSheet.Protect "123",_
Contents:=True,Scenarios:=True
objExl.Application.IgnoreRemoteRequests = False
objExl.Visible = True '使EXCEL可见
objExl.Application.WindowState = xlMaximized 'EXCEL的显示方式为最大化
objExl.ActiveWindow.WindowState = xlMaximized '工作薄显示方式为最大化
objExl.SheetsInNewWorkbook = 3 '将默认新工作薄数量改回3个
Set objExl = Nothing '清除对象
Me.MousePointer = 0 '修改鼠标
Exit Sub

err1:
objExl.SheetsInNewWorkbook = 3
objExl.DisplayAlerts = False '关闭时不提示保存
objExl.Quit '关闭EXCEL
objExl.DisplayAlerts = True '关闭时提示保存
Set objExl = Nothing
Me.MousePointer = 0
End Sub

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
全面控制 Excel

首先创建 Excel 对象，使用ComObj:
Dim ExcelID as Excel.Application
Set ExcelID as new Excel.Application

1) 显示当前窗口：ExcelID.Visible := True;

2) 更改 Excel 标题栏：ExcelID.Caption := '应用程序调用 Microsoft Excel';

3) 添加新工作簿：ExcelID.WorkBooks.Add;

4) 打开已存在的工作簿：ExcelID.WorkBooks.Open( 'C:\Excel\Demo.xls' );

5) 设置第2个工作表为活动工作表：ExcelID.WorkSheets[2].Activate;
或 ExcelID.WorkSheets[ 'Sheet2' ].Activate;

6) 给单元格赋值：ExcelID.Cells[1,4].Value := '第一行第四列';

7) 设置指定列的宽度（单位：字符个数），以第一列为例：
ExcelID.ActiveSheet.Columns[1].ColumnsWidth := 5;

8) 设置指定行的高度（单位：磅）（1磅＝0.035厘米），以第二行为例：
ExcelID.ActiveSheet.Rows[2].RowHeight := 1/0.035; // 1厘米

9) 在第8行之前插入分页符：
ExcelID.WorkSheets[1].Rows[8].PageBreak := 1;

10) 在第8列之前删除分页符：
ExcelID.ActiveSheet.Columns[4].PageBreak := 0;

11) 指定边框线宽度：
ExcelID.ActiveSheet.Range[ 'B3:D4' ].Borders[2].Weight := 3;
1-左 2-右 3-顶 4-底 5-斜( \ ) 6-斜( / )

12) 清除第一行第四列单元格公式：ExcelID.ActiveSheet.Cells[1,4].ClearContents;

13) 设置第一行字体属性：
ExcelID.ActiveSheet.Rows[1].Font.Name := '隶书';
ExcelID.ActiveSheet.Rows[1].Font.Color := clBlue;
ExcelID.ActiveSheet.Rows[1].Font.Bold := True;
ExcelID.ActiveSheet.Rows[1].Font.UnderLine := True;

14) 进行页面设置：
a.页眉：ExcelID.ActiveSheet.PageSetup.CenterHeader := '报表演示';
b.页脚：ExcelID.ActiveSheet.PageSetup.CenterFooter := '第&P页';
c.页眉到顶端边距2cm：ExcelID.ActiveSheet.PageSetup.HeaderMargin := 2/0.035;
d.页脚到底端边距3cm：ExcelID.ActiveSheet.PageSetup.HeaderMargin := 3/0.035;
e.顶边距2cm：ExcelID.ActiveSheet.PageSetup.TopMargin := 2/0.035;
f.底边距2cm：ExcelID.ActiveSheet.PageSetup.BottomMargin := 2/0.035;
g.左边距2cm：ExcelID.ActiveSheet.PageSetup.LeftMargin := 2/0.035;
h.右边距2cm：ExcelID.ActiveSheet.PageSetup.RightMargin := 2/0.035;
i.页面水平居中：ExcelID.ActiveSheet.PageSetup.CenterHorizontally := 2/0.035;
j.页面垂直居中：ExcelID.ActiveSheet.PageSetup.CenterVertically := 2/0.035;
k.打印单元格网线：ExcelID.ActiveSheet.PageSetup.PrintGridLines := True;

15) 拷贝操作：
a.拷贝整个工作表：ExcelID.ActiveSheet.Used.Range.Copy;
b.拷贝指定区域：ExcelID.ActiveSheet.Range[ 'A1:E2' ].Copy;
c.从A1位置开始粘贴：ExcelID.ActiveSheet.Range.[ 'A1' ].PasteSpecial;
d.从文件尾部开始粘贴：ExcelID.ActiveSheet.Range.PasteSpecial;

16) 插入一行或一列：
a. ExcelID.ActiveSheet.Rows[2].Insert;
b. ExcelID.ActiveSheet.Columns[1].Insert;

17) 删除一行或一列：
a. ExcelID.ActiveSheet.Rows[2].Delete;
b. ExcelID.ActiveSheet.Columns[1].Delete;

18) 打印预览工作表：
ExcelID.ActiveSheet.PrintPreview;

19) 打印输出工作表：
ExcelID.ActiveSheet.PrintOut;

20) 工作表保存：
If not ExcelID.ActiveWorkBook.Saved then
ExcelID.ActiveSheet.PrintPreview
　 End if

21) 工作表另存为：
ExcelID.SaveAs( 'C:\Excel\Demo1.xls' );

22) 放弃存盘：
ExcelID.ActiveWorkBook.Saved := True;

23) 关闭工作簿：
ExcelID.WorkBooks.Close;

24) 退出 Excel：ExcelID.Quit;

25) 设置工作表密码:
ExcelID.ActiveSheet.Protect "123",Scenarios:=True

26) EXCEL的显示方式为最大化
ExcelID.Application.WindowState = xlMaximized

27) 工作薄显示方式为最大化
ExcelID.ActiveWindow.WindowState = xlMaximized

28) 设置打开默认工作薄数量
ExcelID.SheetsInNewWorkbook = 3

29) '关闭时是否提示保存(true 保存；false 不保存)
ExcelID.DisplayAlerts = False

30) 设置拆分窗口,及固定行位置
ExcelID.ActiveWindow.SplitRow = 1
ExcelID.ActiveWindow.FreezePanes = True

31) 设置打印时固定打印内容
ExcelID.ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"

32) 设置打印标题
ExcelID.ActiveSheet.PageSetup.PrintTitleColumns = ""

33) 设置显示方式(分页方式显示)
ExcelID.ActiveWindow.View = xlPageBreakPreview

34) 设置显示比例
ExcelID.ActiveWindow.Zoom = 100

35) 让Excel 响应 DDE 请求
Ex.Application.IgnoreRemoteRequests = False

用VB操作Excel(VB6.0)(整理)
2008-09-23 22:16:30| 分类： 文章转载 | 标签：excel office |字号 订阅
用VB操作Excel(VB6.0)(整理)
全面控制Excel:
首先创建Excel对象，使用ComObj:
Dim ExcelID as Excel.Application
Set ExcelID as new Excel.Application

1)显示当前窗口：
ExcelID.Visible:=True;
2)更改Excel标题栏：
ExcelID.Caption:='应用程序调用MicrosoftExcel';
3)添加新工作簿：
ExcelID.WorkBooks.Add;
4)打开已存在的工作簿：
ExcelID.WorkBooks.Open('C:\Excel\Demo.xls');
5)设置第2个工作表为活动工作表：
ExcelID.WorkSheets[2].Activate;
或ExcelID.WorkSheets['Sheet2'].Activate;
6)给单元格赋值：
ExcelID.Cells[1,4].Value:='第一行第四列';
7)设置指定列的宽度（单位：字符个数），以第一列为例：
ExcelID.ActiveSheet.Columns[1].ColumnsWidth:=5;
8)设置指定行的高度（单位：磅）（1磅＝0.035厘米），以第二行为例：
ExcelID.ActiveSheet.Rows[2].RowHeight:=1/0.035;//1厘米
9)在第8行之前插入分页符：
ExcelID.WorkSheets[1].Rows[8].PageBreak:=1;
10)在第8列之前删除分页符：
ExcelID.ActiveSheet.Columns[4].PageBreak:=0;
11)指定边框线宽度：
ExcelID.ActiveSheet.Range['B3:D4'].Borders[2].Weight:=3;
1-左 2-右 3-顶4-底 5-斜(\) 6-斜(/)
12)清除第一行第四列单元格公式：
ExcelID.ActiveSheet.Cells[1,4].ClearContents;
13)设置第一行字体属性：
ExcelID.ActiveSheet.Rows[1].Font.Name:='隶书';
ExcelID.ActiveSheet.Rows[1].Font.Color :=clBlue;
ExcelID.ActiveSheet.Rows[1].Font.Bold :=True;
ExcelID.ActiveSheet.Rows[1].Font.UnderLine:=True;
14)进行页面设置：
a.页眉：
ExcelID.ActiveSheet.PageSetup.CenterHeader:='报表演示';
b.页脚：
ExcelID.ActiveSheet.PageSetup.CenterFooter:='第&P页';
c.页眉到顶端边距2cm：
ExcelID.ActiveSheet.PageSetup.HeaderMargin:=2/0.035;
d.页脚到底端边距3cm：
ExcelID.ActiveSheet.PageSetup.HeaderMargin:=3/0.035;
e.顶边距2cm：
ExcelID.ActiveSheet.PageSetup.TopMargin:=2/0.035;
f.底边距2cm：
ExcelID.ActiveSheet.PageSetup.BottomMargin:=2/0.035;
g.左边距2cm：
ExcelID.ActiveSheet.PageSetup.LeftMargin:=2/0.035;
h.右边距2cm：
ExcelID.ActiveSheet.PageSetup.RightMargin:=2/0.035;
i.页面水平居中：
ExcelID.ActiveSheet.PageSetup.CenterHorizontally:=2/0.035;
j.页面垂直居中：
ExcelID.ActiveSheet.PageSetup.CenterVertically:=2/0.035;
k.打印单元格网线：
ExcelID.ActiveSheet.PageSetup.PrintGridLines:=True;
15)拷贝操作：
a.拷贝整个工作表：
ExcelID.ActiveSheet.Used.Range.Copy;
b.拷贝指定区域：
ExcelID.ActiveSheet.Range['A1:E2'].Copy;
c.从A1位置开始粘贴：
ExcelID.ActiveSheet.Range.['A1'].PasteSpecial;
d.从文件尾部开始粘贴：
ExcelID.ActiveSheet.Range.PasteSpecial;
16)插入一行或一列：
a.ExcelID.ActiveSheet.Rows[2].Insert;
b.ExcelID.ActiveSheet.Columns[1].Insert;
17)删除一行或一列：
a.ExcelID.ActiveSheet.Rows[2].Delete;
b.ExcelID.ActiveSheet.Columns[1].Delete;
18)打印预览工作表：
ExcelID.ActiveSheet.PrintPreview;
19)打印输出工作表：
ExcelID.ActiveSheet.PrintOut;
20)工作表保存：
IfnotExcelID.ActiveWorkBook.Savedthen
ExcelID.ActiveSheet.PrintPreview
Endif
21)工作表另存为：
ExcelID.SaveAs('C:\Excel\Demo1.xls');
22)放弃存盘：
ExcelID.ActiveWorkBook.Saved:=True;
23)关闭工作簿：
ExcelID.WorkBooks.Close;
24)退出Excel：
ExcelID.Quit;
25)设置工作表密码:
ExcelID.ActiveSheet.Protect"123",Scenarios:=True
26)EXCEL的显示方式为最大化
ExcelID.Application.WindowState=xlMaximized
27)工作薄显示方式为最大化
ExcelID.ActiveWindow.WindowState=xlMaximized
28)设置打开默认工作薄数量
ExcelID.SheetsInNewWorkbook=3
29)'关闭时是否提示保存(true保存；false不保存)
ExcelID.DisplayAlerts=False
30)设置拆分窗口,及固定行位置
ExcelID.ActiveWindow.SplitRow=1
ExcelID.ActiveWindow.FreezePanes=True
31)设置打印时固定打印内容
ExcelID.ActiveSheet.PageSetup.PrintTitleRows="$1:$1"
32)设置打印标题
ExcelID.ActiveSheet.PageSetup.PrintTitleColumns=""
33)设置显示方式(分页方式显示)
ExcelID.ActiveWindow.View=xlPageBreakPreview
34)设置显示比例
ExcelID.ActiveWindow.Zoom=100
35)让Excel响应DDE请求
Ex.Application.IgnoreRemoteRequests=False
用VB操作EXCEL示例代码
Private Sub Command3_Click()
On Error GoTo err1
Dim i As Long
Dim j As Long
Dim objExl As Excel.Application '声明对象变量
Me.MousePointer=11 '改变鼠标样式
Set objExl=New Excel.Application'初始化对象变量
objExl.SheetsInNewWorkbook=1 '将新建的工作薄数量设为1
objExl.Workbooks.Add'增加一个工作薄
objExl.Sheets(objExl.Sheets.Count).Name="book1" '修改工作薄名称
objExl.Sheets.Add,objExl.Sheets("book1")‘增加第二个工作薄在第一个之后
objExl.Sheets(objExl.Sheets.Count).Name="book2"
objExl.Sheets.Add,objExl.Sheets("book2")‘增加第三个工作薄在第二个之后
objExl.Sheets(objExl.Sheets.Count).Name="book3"

objExl.Sheets("book1").Select '选中工作薄<book1>
For i=1 To 50'循环写入数据
For j=1 To 5
If i=1 Then
objExl.Selection.NumberFormatLocal="@" '设置格式为文本
objExl.Cells(i,j)="E"&i&j
Else
objExl.Cells(i,j)=i&j
EndIf
Next
Next
objExl.Rows("1:1").Select '选中第一行
objExl.Selection.Font.Bold=True '设为粗体
objExl.Selection.Font.Size=24 '设置字体大小
objExl.Cells.EntireColumn.AutoFit '自动调整列宽
objExl.ActiveWindow.SplitRow=1 '拆分第一行
objExl.ActiveWindow.SplitColumn=0 '拆分列
objExl.ActiveWindow.FreezePanes=True '固定拆分objExl.ActiveSheet.PageSetup.PrintTitleRows="$1:$1" '设置打印固定行
objExl.ActiveSheet.PageSetup.PrintTitleColumns=""'打印标题objExl.ActiveSheet.PageSetup.RightFooter="打印时间:"&_
Format(Now,"yyyy年mm月dd日hh:MM:ss")
objExl.ActiveWindow.View=xlPageBreakPreview'设置显示方式
objExl.ActiveWindow.Zoom=100 '设置显示大小
'给工作表加密码
objExl.ActiveSheet.Protect"123",Scenarios:=True
objExl.Application.IgnoreRemoteRequests=False
objExl.Visible=True '使EXCEL可见
objExl.Application.WindowState=xlMaximized'EXCEL的显示方式为最大化
objExl.ActiveWindow.WindowState=xlMaximized'工作薄显示方式为最大化
objExl.SheetsInNewWorkbook=3 '将默认新工作薄数量改回3个
Set objExl=Nothing'清除对象
Me.MousePointer=0 '修改鼠标
ExitSub
err1:
objExl.SheetsInNewWorkbook=3

objExl.DisplayAlerts=False '关闭时不提示保存
objExl.Quit'关闭EXCEL
objExl.DisplayAlerts=True '关闭时提示保存
Set objExl=Nothing
Me.MousePointer=0
End Sub
如何实现VB与EXCEL的无缝连接

-----------------------------

Dim xlApp As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet

Private Sub Command1_Click()
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add

Dim strDate As String,"错误"
End If

xlBook.Save

xlBook.Close
Set xlSheet = Nothing
Set xlBook = Nothing
' xlApp.Visible = True
xlApp.Quit
Set xlApp = Nothing
End Sub
Private Sub Command1_Click()
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add

Dim strDate As String,"错误"
End If

xlBook.Save

xlBook.Close
Set xlSheet = Nothing
Set xlBook = Nothing
' xlApp.Visible = True
xlApp.Quit
Set xlApp = Nothing
End Sub

Sub test1()
'
Dim xlApp As New Excel.Application
Dim ExcelID As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Dim strName As String

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add

Set ExcelID = New Excel.Application

strName = CurrentProject.Path + "\aaa.xls"
Debug.Print strName
xlBook.SaveAs strName

Set xlBook = xlApp.Workbooks.Open(strName)
Set xlSheet = xlBook.Worksheets(1)

xlSheet.Range("A1").Value = "abcdefg"
xlSheet.Range("A2").Value = "abcdefg2"
xlSheet.Cells(2,2).Value = "bbbb"
' xlApp.Workbooks [1].Activate
xlApp.ActiveSheet.Rows(2).Insert
' ExcelID.Workbooks(1).Activate
' ExcelID.ActiveSheet.Rows(2).Insert
' xlSheet.Rows [2].Insert

xlApp.Visible = True
xlBook.Save
xlBook.Close

Set xlSheet = Nothing
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
Debug.Print "ok"

End Sub

Dim excelfile As Excel.Application,excelsheet As Excel.Worksheet
Dim lastCol As Long,lastRow As Long
Dim strFile As String

Private Sub importExcelDate()
'
On Error GoTo Err_importExcelDate
Dim result As Integer

With Me.Application.FileDialog(msoFileDialogFilePicker)
.Title = "请选择EXCEL文件"
.Filters.Add "EXCEL2000-2003","*.xls"
.Filters.Add "EXCEL2007-2010","*.xlsx"
.FilterIndex = 1
.AllowMultiSelect = False
result = .Show
If result <> 0 Then
strFile = Trim(.SelectedItems.Item(1))
Else
MsgBox "没有选择文件","提示"
Exit Sub
End If
End With
Debug.Print strFile

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count
Debug.Print lastCol: Debug.Print lastRow

Debug.Print excelsheet.Cells(1,1)

Call importALLDate

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing
MsgBox "导入完成",vbOKOnly,"完成"
Exit Sub
Err_importExcelDate:
Debug.Print Err.Description
End Sub

Private Sub ImportExcelData()
'
On Error GoTo Err_ImportExcelData
' Dim strFile As String
Dim strB1() As String,intTmp1 As Integer

DoCmd.Runsql "DELETE * FROM APTmp "
Me.CommonDialog8.CancelError = True

Me.CommonDialog8.ShowOpen
strFile = Me.CommonDialog8.Filename
If Me.CommonDialog8.Filename = "" Then
Exit Sub
End If


Debug.Print strFile
If strFile = "" Then
MsgBox "没有选择文件","错误"
' Exit Sub
' End If


Call ImportAPData(strFile)
strFile = SetstrFile

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing

Exit_ImportExcelData:
Exit Sub
Err_ImportExcelData:
' MsgBox Err.Description
Resume Exit_ImportExcelData
End Sub

Private Sub ImportAPData(strTmp1 As String)
'
Dim i2 As Long

For i2 = 2 To lastRow
Debug.Print excelsheet.Cells(i2,"APT") = True Then
' 1 2 3 4 5 6 7 8
strsql = "INSERT INTO APTmp ( OrderType,"
strsql = strsql + "VALUES('" + Trim("CIP") + "',8))) + "') "
' strsql = strsql + "'" + strTmp1 + "'" + ") "
Debug.Print strsql
DoCmd.Runsql strsql
End If
Next i2
Call ImportTAPData
End Sub

Private Sub Command10_Click() '导入分单
On Error GoTo Err_Command10_Click
Dim strFile As String

Me.CommonDialog8.ShowOpen
strFile = Me.CommonDialog8.Filename

Debug.Print strFile
If strFile = "" Then
MsgBox "没有选择文件","错误"
Exit Sub
End If

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count

Debug.Print lastCol
Debug.Print lastRow

Debug.Print excelsheet.Cells(1,1)

If ImportHAWBData = False Then
MsgBox "导入未成功，请检查文件中有没有重复的DN","提示"
' Exit Sub
End If

Call updateHAWB

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing

Exit_Command10_Click:
Exit Sub

Err_Command10_Click:
MsgBox Err.Description
Resume Exit_Command10_Click

End Sub

Public Function ImportHAWBData() As Boolean
'
On Error GoTo Err_ImportHAWBData
Dim i7 As Long
Dim rst1 As DAO.Recordset

strsql = "SELECT HAWBTmp.DN,HAWBTmp.HAWB,HAWBTmp.ISIMPORT "
strsql = strsql + "FROM HAWBTmp; "
Debug.Print strsql

Set rst1 = CurrentDb.OpenRecordset(strsql)

For i7 = 2 To lastRow
Debug.Print excelsheet.Cells(i7,1)
If excelsheet.Cells(i7,1) <> "" And excelsheet.Cells(i7,2) <> "" Then
If checkDN(Trim(CStr(excelsheet.Cells(i7,1)))) = True Then
rst1.AddNew
rst1.Fields(0) = Trim(CStr(excelsheet.Cells(i7,1)))
rst1.Fields(1) = Trim(CStr(excelsheet.Cells(i7,2)))
rst1.Update
End If
End If
Next i7
ImportHAWBData = True
Exit Function
Err_ImportHAWBData:
MsgBox Err.Description
ImportHAWBData = False
End Function

Private Sub ImportExcelData()
'
On Error GoTo Err_ImportExcelData
Dim strFile As String
Dim strB1() As String,"错误"
' Exit Sub
' End If


Call ImportAPData(strFile)

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing

Exit_ImportExcelData:
Exit Sub
Err_ImportExcelData:
MsgBox Err.Description
Resume Exit_ImportExcelData
End Sub

Private Sub ImportAPData(strTmp1 As String)
'
Dim i2 As Long

For i2 = 2 To lastRow
Debug.Print excelsheet.Cells(i2,"APT") = True Then
'----2012/7/25--更新添加R8TS的规则，其规则为当ROUTE字段为CMBLP1时自动添加时间戳为分单号
' 1 2 3 4 5 6 7 8
strsql = "INSERT INTO APTmp ( OrderType,HAWB ) "
strsql = strsql + "VALUES('" + Trim(CStr(excelsheet.Cells(i2,"
If checkRoute(Trim(CStr(excelsheet.Cells(i2,5)))) = False Then
strsql = strsql + "'" + Trim(CStr(excelsheet.Cells(i2,8))) + "') "
Else
strsql = strsql + "'" + addR8TSHAWB + "')"
End If
' strsql = strsql + "'" + strTmp1 + "'" + ") "
Debug.Print strsql
DoCmd.Runsql strsql
End If
Next i2
Call ImportTAPData
End Sub

Private Sub ImportExcelFile()
'
Me.CommonDialog2.CancelError = True
Me.CommonDialog2.ShowOpen
strFile = Me.CommonDialog2.Filename
If Me.CommonDialog2.Filename = "" Then
Exit Sub
End If

Debug.Print strFile
If strFile = "" Then
MsgBox "没有选择文件","错误"
End If

Set excelfile = New Excel.Application
Set excelwbook = excelfile.Workbooks.Open(strFile)
Set excelsheet = excelwbook.Sheets(1)

lastCol = excelsheet.UsedRange.Columns.Count
lastRow = excelsheet.UsedRange.Rows.Count
Debug.Print lastCol
Debug.Print lastRow

Call importHEADFile

excelwbook.Close
excelfile.Quit
Set excelfile = Nothing
Set excelwbook = Nothing

End Sub

Private Sub Command10_Click() '导入分单
On Error GoTo Err_Command10_Click
Dim strFile As String

Me.CommonDialog8.ShowOpen
strFile = Me.CommonDialog8.Filename

Debug.Print strFile
If strFile = "" Then
MsgBox "没有选择文件",2)))
rst1.Update
End If
End If
Next i7
ImportHAWBData = True
Exit Function
Err_ImportHAWBData:
MsgBox Err.Description
ImportHAWBData = False
End Function

Private Sub ImportExcelData() ' Dim strFile As String Dim strB1() As String Dim intTmp1 As Integer ' DoCmd.Runsql "DELETE * FROM APTmp " Me.CommonDialog5.ShowOpen strFile = Me.CommonDialog5.Filename Debug.Print strFile If strFile = "" Then MsgBox "没有选择文件","错误" Exit Sub End If Set excelfile = New Excel.Application Set excelwbook = excelfile.Workbooks.Open(strFile) Set excelsheet = excelwbook.Sheets(1) lastCol = excelsheet.UsedRange.Columns.Count lastRow = excelsheet.UsedRange.Rows.Count Debug.Print lastCol Debug.Print lastRow Debug.Print excelsheet.Cells(1,1) strB1 = Split(strFile,"\") intTmp1 = UBound(strB1) strFile = strB1(intTmp1) Debug.Print strFile Call ImportItemData(strFile) Call updateDN excelwbook.Close excelfile.Quit Set excelfile = Nothing Set excelwbook = Nothing Me.Child2.Requery End Sub ' strB1 = Split(strFile,"\") ' intTmp1 = UBound(strB1) ' strFile = strB1(intTmp1) ' Debug.Print strFile Private Sub ImportItemData(strTmp1 As String) ' Dim i2 As Long For i2 = 2 To lastRow Debug.Print excelsheet.Cells(i2,1) strsql = "INSERT INTO ITEM ( DNNo,Item,Material,Refdoc,DlvQty,SU,AcGIDate,QTY,IFN ) " strsql = strsql + "VALUES('" + Trim(CStr(excelsheet.Cells(i2," strsql = strsql + "'" + Trim(CStr(excelsheet.Cells(i2,13))) + "',14))) + "'," strsql = strsql + "#" + Trim(CStr(excelsheet.Cells(i2,15))) + "#,17))) + "'," strsql = strsql + "'" + strTmp1 + "' " strsql = strsql + "); " Debug.Print strsql DoCmd.Runsql strsql Next i2 End Sub