VBA ADO+SQL实例集锦

1, 包含空值的记录 f13 is null

‘http://www.excelpx.com/dispbbs.asp?boardID=5&ID=46032&page=1

‘订单生成系统.xls

‘f6-第 6 列，f2-第 2 列

Private Sub Worksheet_Activate()

On Error Resume Next

Dim x As Object, yy As Object, sql As String

Set x = CreateObject("ADODB.Connection")

Range("a1:h1") = Array("编号", "品名", "规格", "产地", "单位", "件装", "属性", "计划") ‘表头

另外赋值

[a2].CopyFromRecordset yy

Set yy = Nothing

Set x = Nothing

End Sub

2，用 ADO Connection 对象查询

Option Explicit

Public conn As ADODB.Connection

Sub Myquery()

名要用[$],条件部分用单引号''

ThisWorkbook.Sheets("sheet1").Cells(2, 1).CopyFromRecordset conn.Execute(sql1) 'copy 后

面紧接 SQL 查询执行语句

With Sheets("sheet1")

.Range("A1") = "物料代码" '建立表头

.Range("B1") = "物料描述"

.Range("C1") = "属性"

.Range("D1") = "单位"

End With

'conn.Close '可不用每次关闭数据源的连接

Option Explicit

Sub Myquery()

'conn.Open sConnect '打开数据源

rd.Open sql1, sConnect, adOpenForwardOnly, adLockReadOnly

ThisWorkbook.Sheets("sheet1").Cells(2, 1).CopyFromRecordset rd

.Range("A1") = "物料代码" '建立表头

.Range("B1") = "物料描述"

.Range("C1") = "属性"

.Range("D1") = "单位"

End With

rd.Close '关闭记录集

Set rd=Nothing '关闭

End Sub

4，引用一列，如 A 列

‘引用单列、单行、单个单元格.xls

'引用一列，如 A 列

Sub onecolumn()

Dim Sql$

Cells.Clear

End Sub

Sub dgzbhz()

'2008/12/2

‘http://www.exceljy.com/viewthread.php?tid=4912&pid=82252&page=1&extra=page

%3D1#pid82252

‘Book12021.xls

‘由于分表的第 2 列表头是“金额”，不用它，改为“一中”，所以要用 hdr=no 无标题，拷贝时

把第一行表头归零，所以最后要加表头。

Dim Sql$

Set Conn = CreateObject("Adodb.Connection")

Cells(1, i + 2).CopyFromRecordset Conn.Execute(Sql)

Conn.Close

Next i

Set Conn = Nothing

[b1:d1] = arr

End Sub

‘test1203.xls EH

‘有标题不用 hdr=no，列名用编码文字，可往下连续取数据。

Private Function cnn() As Object

Set cnn = CreateObject("ADODB.Connection")

Set Sht1 = Sheets("汇总")

Sht1.Activate

‘Set Conn = CreateObject("Adodb.Connection")

For Each Sht In Sheets

If Sht.Name <> "汇总" Then

Sql = "select 编码 from [" & Sht.Name & "$]"

Sht1.Cells(n, 2).CopyFromRecordset Cnn.Execute(Sql)

End If

Next Sht

Cnn.Close

Set Cnn = Nothing

End Sub

5，引用一行,如第 1 行

'引用一

Sub onerow()

Dim Sql$

Set Conn = CreateObject("Adodb.Connection")

Conn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;hdr=no';data

source=" & ThisWorkbook.Path & "\1.xls"

Cells.Clear

[a1].CopyFromRecordset Conn.Execute(Sql)

Conn.Close

End Sub

Dim myPath$, mvvar, i&, myName$, Myr&

Sheet1.Activate

mvvar = FileList(myPath)

Conn.Open "provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel

12.0;hdr=no';data source=" & ThisWorkbook.Path & "\" & mvvar(i)

Sql = "select * from [sheet1$h6:h6]"

Myr = [a65536].End(xlUp).Row + 1

If Myr < 4 Then Myr = 4

Cells(Myr, 3).CopyFromRecordset Conn.Execute(Sql)

Cells(Myr, 1) = Myr - 3

Cells(Myr, 4).CopyFromRecordset Conn.Execute(Sql)

Sql = "select * from [sheet1$c15:c15]"

Sql = "select * from [sheet1$c16:c16]"

Else

MsgBox "没有找到文件。"

End If

Myr = Myr + 1

Cells(Myr, 2) = "合计"

Cells(Myr, 3).Formula = "=sum(r4c:r[-1]c)"

Cells(Myr, 3).AutoFill Cells(Myr, 3).Resize(1, 5)

End Sub

Function FileList(fldr, Optional fltr As String = "*.xls") As Variant

Dim sTemp As String, sHldr As String

FileList = False

sHldr = Dir

If sHldr = "" Then Exit Do

sTemp = sTemp & "|" & sHldr