vba代码运行错误3706

007feiren · 发表于 2024-9-19 15:27

本帖最后由 007feiren 于 2024-9-20 08:33 编辑

网上得到一个代码，比较两个工作表异同：
Sub Sheet1中有而Sheet2中没有()
' 清除A2到A1000区域的内容
Range("A2:A1000").ClearContents
' 创建并设置ADO数据库连接对象
Set conn = CreateObject("adodb.connection")
conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
' 定义SQL查询，查找在Sheet1中有但在Sheet2中没有的“姓名”
Sq1 = "select Distinct * from [Sheet1$] where 姓名 not in(select 姓名 from [Sheet2$])"
' 执行查询并将结果复制到A2单元格开始的区域
[a2].CopyFromRecordset conn.Execute(Sq1)
' 关闭连接并释放对象
conn.Close
Set conn = Nothing
End Sub
但是运行时出现3706错误，

请高手帮助指点一下，这个错误怎么解决！

ykcbf1100 · 发表于 2024-9-19 18:26

你不上附件别人没法帮你。

007feiren · 发表于 2024-9-20 08:34

ykcbf1100 发表于 2024-9-19 18:26
你不上附件别人没法帮你。

附件已上传

ykcbf1100 · 发表于 2024-9-20 09:06

007feiren 发表于 2024-9-20 08:34
附件已上传

不会SQL，改用字典

一个代码就够了。。。

ykcbf1100 · 发表于 2024-9-20 09:07

参与一下。。。

Sub ykcbf() '//2024.9.20
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
arr = Sheets("Sheet1").UsedRange
For i = 2 To UBound(arr)
If arr(i, 1) <> Empty Then
d(arr(i, 1)) = ""
End If
Next
brr = Sheets("Sheet2").UsedRange
For i = 2 To UBound(brr)
If brr(i, 1) <> Empty Then
d1(brr(i, 1)) = ""
End If
Next
ReDim zrr(1 To 10000, 1 To 3)
For i = 2 To UBound(arr)
s = arr(i, 1)
If Not d1.exists(s) Then
m = m + 1
zrr(m, 1) = s
zrr(m, 3) = s
End If
Next
n = 0
For i = 2 To UBound(brr)
s = brr(i, 1)
If Not d.exists(s) Then
n = n + 1
zrr(n, 2) = s
zrr(m + n, 3) = s
End If
Next
Set d = Nothing
Set d1 = Nothing
With Sheets("Sheet3")
.UsedRange.Offset(1).ClearContents
.[a2].Resize(m + n, 3) = zrr
End With
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

007feiren · 发表于 2024-9-20 16:40

ykcbf1100 发表于 2024-9-20 09:07
参与一下。。。

感谢，你也是个高手！

		自动登录	找回密码
密码			免费注册

[求助] vba代码运行错误3706