加入收藏 | 设为首页 | 会员中心 | 我要投稿 李大同 （https://www.lidatong.com.cn/）- 科技、建站、经验、云计算、5G、大数据,站长网!
当前位置： 首页 > 大数据 > 正文

VB操作EXCEL文件大全

发布时间：2020-12-17 00:15:29 所属栏目：大数据 来源：网络整理
导读：Private Sub writeToExcel(strTmp1() As String,colTmp1 As Collection)'' Dim tmp1 Dim i1 As Integer,intCol As Integer,intRow As Integer Dim xlApp As New Excel.Application Dim xlBook As New Excel.Workbook Dim xlSheet As New Excel.Worksheet Dim


Private Sub writeToExcel(strTmp1() As String,colTmp1 As Collection)
'
'    Dim tmp1
    Dim i1 As Integer,intCol As Integer,intRow As Integer
    Dim xlApp As New Excel.Application
    Dim xlBook As New Excel.Workbook
    Dim xlSheet As New Excel.Worksheet
    Dim strName As String,strArray1() As String
    Dim strS1 As String
    Dim strD1 As String
    
    strS1 = CurrentProject.Path + "template.xls"
    strD1 = CurrentProject.Path + "" + CStr(Format(Now,"YYYYMMDDHHMMSS")) + "aaa1.xls"
    
    
'    For i1 = 0 To UBound(strTmp1) - 1
'        Debug.Print strTmp1(i1) + " " + CStr(i1)
'    Next i1
    
'    strName = CurrentProject.Path + "aaa1.xls"
    FileCopy strS1,strD1
    
    Set xlApp = CreateObject("Excel.Application")
        xlApp.Visible = False
'    Set xlBook = xlApp.Workbooks.Open(strName)

    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:ExcelDemo.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:ExcelDemo1.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))),"APT") = True Then
        
            If checkRoute(Trim(CStr(excelsheet.Cells(i2,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:ExcelDemo.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:ExcelDemo1.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:ExcelDemo.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:ExcelDemo1.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",_
  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
如何实现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 "没有选择文件",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

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!
    相关内容
      推荐文章
        站长推荐
        热点阅读

          【免责声明】本站内容转载自互联网，其发布内容言论不代表本站观点，如果其链接、内容的侵犯您的权益，烦请提交相关链接至邮箱bqsm@foxmail.com我们将及时予以处理。

          建议您使用1920×1080分辨率、谷歌浏览器Google Chrome、Microsoft Edge以获得本站的最佳浏览效果

          Copygight © 2008-2022 https://www.lidatong.com.cn/ All Rights Reserved. 李大同