|
|
ADO导至Excel
[code=vb]
Sub InsertValues()
Dim cnn, rst, rst1, strSqlL$, strSqlM$, strSqlR$, bool As Boolean
Dim tblName$, myPathFull$, strSqlc$, myPath$, t, i%
Set cnn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
Set rst1 = CreateObject("ADODB.Recordset")
myPathFull = ThisWorkbook.Path & "\" & "数据源2\数据源2.xls"
myPath = ThisWorkbook.Path & "\" & "Data\Data.xls"
Application.DisplayAlerts = False
strSqlL = "Select 商品编号 as fNumber,送货单位 as company,first(日期) as fdate,first(商品名称) as fName," & _
"first(单位) as unit,first(单价) as price,first(数量) as quantity,first(金额) as fmoney From(Select" & _
" * From[Sheet1$A:H] Order by 日期,商品编号,送货单位) "
strSqlR = " Group by 商品编号,送货单位"
On Error Resume Next
Workbooks.Open Filename:=myPath
If Err.Number <> 0 Then
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=myPath
End If
cnn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;" & _
"Data Source=" & myPathFull
Set rst = cnn.Execute("Select distinct 商品编号 From[Sheet1$C:C]")
With Workbooks("Data.xls")
Do Until rst.EOF
tblName = rst(0).Value
strSqlM = "Where 商品编号='" & tblName & "'"
Set rst1 = cnn.Execute(strSqlL & strSqlM & strSqlR)
For Each sht In .Worksheets
If sht.Name = tblName Then
bool = True
End If
Next sht
If Not bool Then .Worksheets.Add: .ActiveSheet.Name = tblName
.Worksheets(tblName).Range("A2").CopyFromRecordset rst1
For i = 0 To 7
.Worksheets(tblName).Cells(1, i + 1) = rst1.Fields(i).Name
Next i
rst.MoveNext
Loop
.Worksheets("Sheet1").Delete
.Close True
End With
Application.DisplayAlerts = True
cnn.Close
Set rst = Nothing: Set rst1 = Nothing: Set cnn = Nothing
End Sub
[/code]
<======================================================>
以下是我的解题思路,虽然我更喜欢用链接表方式做.呵呵....
Access导入Excel数据
[code=vb]
Option Compare Database
Sub test()
Dim myPathFull$, cnn, rst, tblName$, i%, t%
Dim strSqlL$, strSqlR$, strSqlM$, arrSql() As String
On Error Resume Next
Set cnn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset"): i = 0
myPathFull = Left(CurrentDb.Name, Len(CurrentDb.Name) - 14) & "数据源2\数据源2.xls"
strSqlL = " Select 商品编号 as fNumber,送货单位 as company,first(日期) as fdate,first(商品名称) as fName," & _
"first(单位) as unit,first(单价) as price,first(数量) as quantity,first(金额) as fmoney From(Select" & _
" * From[Sheet1$A:H] In '" & myPathFull & "'[Excel 8.0;] Order by 日期,商品编号,送货单位) "
strSqlR = " Group by 商品编号,送货单位"
cnn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;" & _
"Data Source=" & myPathFull
Set rst = cnn.Execute("Select distinct 商品编号 From[Sheet1$C:C]")
ReDim arrSql(1)
While Not rst.EOF
tblName = rst(0).Value
strSqlM = "Where 商品编号='" & tblName & "'"
strSqlc = "Create table " & tblName & " (fNumber text(5),company text(20),fdate datetime," & _
"fName text(20),unit text(5),price double,quantity double,fmoney double)"
DoCmd.RunSQL strSqlc
DoCmd.RunSQL "Delete * From " & tblName
arrSql(i) = "Insert Into " & tblName & strSqlL & strSqlM & strSqlR
rst.MoveNext: i = i + 1
ReDim Preserve arrSql(UBound(arrSql) + 1)
Wend
cnn.Close
Set cnn = Nothing: Set rst = Nothing
For t = 0 To i
DoCmd.RunSQL arrSql(t)
Next t
End Sub
[/code]
|
本帖子中包含更多资源
您需要 登录 才可以下载或查看，没有账号？免费注册
x
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-11-25 19:43
该贴已经同步到 
发表于 2011-11-28 11:17
