CopyFromRecordset没有实现目标需求。

ning84 · 发表于 2023-4-12 21:30

不知道哪里出问题了。
Rng.CopyFromRecordset Rsn没有实现目标需求，结果为空。

*****************************************
Set Rs1 = Cn.Execute("Select Distinct * From [Sheet1$c2:c6]")
Arr1 = Rs1.GetRows
Set Rs2 = Cn.Execute("Select Distinct * From [d:\ls.xls].[Sheet1$A5:A30]")
Arr2 = Rs2.GetRows

Rs.GetRows实现目标需求。

Sub ll2()
Dim Cn As ADODB.Connection
Dim Rs1 As ADODB.Recordset, Rs2 As ADODB.Recordset
Dim SqlStr, Arr1, Arr2
Set Cn = New ADODB.Connection
Set Rs1 = New ADODB.Recordset
Set Rs2 = New ADODB.Recordset
Set Cn = New ADODB.Connection
Set Rs = New ADODB.Recordset
Cn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
Set Rs1 = Cn.Execute("Select Distinct * From [Sheet1$c2:c6]")
Arr1 = Rs1.GetRows
Set Rs2 = Cn.Execute("Select Distinct * From [d:\ls.xls].[Sheet1$A5:A30]")
Arr2 = Rs2.GetRows
Dim Rng As Range
Set Rng = Sheet1.Cells(1, 10)
Rng.CopyFromRecordset Rs1
Rng.Offset(, 5).CopyFromRecordset Rs2
Stop
End Sub

复制代码

ning84 · 发表于 2023-4-13 06:28

Set Rs = Cn.Execute(SqlStr) 结果Rs.recordcount=-1 不是目标需求

Arr = Rs.GetRows，目标需求的结果

Rng.CopyFromRecordset Rs ，记录集是空集，Rng没有结果。

Sub ll1()
Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim SqlStr, Arr
Set Cn = New ADODB.Connection
Set Rs = New ADODB.Recordset
Set Cn = New ADODB.Connection
Set Rs = New ADODB.Recordset
Cn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
SqlStr = "Select Distinct * From [d:\ls.xls].[Sheet1$A5:c10]"
Set Rs = Cn.Execute(SqlStr)
Debug.Print Rs.RecordCount, ThisWorkbook.FullName
Arr = Rs.GetRows
Dim Rng As Range
Set Rng = Sheet1.Cells(1, "D") '.Resize(10, 20)
Rng.CopyFromRecordset Rs ', 2, 2
Debug.Print Rng.Address,
Debug.Print Rng.Rows.Count, Rng.Columns.Count,
Debug.Print Rng(1, 1), Rng(2, 1),
Debug.Print UBound(Arr), Arr(2, 2)
Stop
Stop
End Sub

复制代码

f8b1987 · 发表于 2023-4-13 08:40

WANT-T · 发表于 2023-4-13 09:48

本帖最后由 WANT-T 于 2023-4-13 09:54 编辑

你在copy之前getrows了，这样rst的eof就变成了true,这时候需求将指针指向第一条记录才能copy出来，rst.movefirst

ivccav · 发表于 2023-4-13 20:30

数据集使用getrows方法后，游标已经是最后一条记录，必须使用 rs1.movefirst把游标移回第一条记录

ning84 · 发表于 2023-5-15 22:19

Set Rs = Cn.Execute(SqlStr)
改成下面语句就可以了。
Rs.Open Str, Cn, adOpenKeyset, adLockOptimistic

Sub SqlDistinctDate()
Dim Rng As Range
Dim Str, oAddress
oAddress = "t$C1:J6000"
Str = "Select Distinct "
Str = Str & " F6 "
Str = Str & " From "
Str = Str & "[" & oAddress & "] Where F6 <> Null"
'Debug.Print Str
Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset
Set Cn = New ADODB.Connection
Set Rs = New ADODB.Recordset
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
'''
Rs.Open Str, Cn, adOpenKeyset, adLockOptimistic
Rs.MoveFirst
For ii = 0 To Rs.RecordCount - 1
Sheets("t").Cells(ii + 1, 1) = Format(Rs.Fields(0), "yyyy年m月")
Rs.MoveNext
Next ii
Set Rng = Sheets("t").Cells(ii + 3, 1).Resize(ii, 1)
Rs.MoveFirst
Rng.CopyFromRecordset Rs
Debug.Print Rng.Address
Rng.Select
Rng.NumberFormatLocal = "yyyy""年""m""月""d""日"";@"
' "yyyy年mm月dd日;@"
Stop
End Sub

复制代码

ning84 · 发表于 2023-5-16 08:58

循环recordset

Rs1.Open Str, Cn, adOpenKeyset, adLockOptimistic--------------不成立

Set Rs1 = Cn.Execute(Str)--------------------成立。

Sub MustDel()
Dim Rng As Range
Set Rng = Sheet2.Cells(3, 1).CurrentRegion
Debug.Print Rng.Address
Dim Str, sStr, oAddress
Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset, Rs1 As ADODB.Recordset
Set Cn = New ADODB.Connection
Set Rs = New ADODB.Recordset
Set Rs1 = New ADODB.Recordset
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
rr = 20
For ii = 1 To Rng.Rows.Count
Str = "Select * From [t$C12:L6000] Where oDate = #" & Rng(ii, 1) & "#"
Debug.Print Str,
'Rs1.Open Str, Cn, adOpenKeyset, adLockOptimistic
Set Rs1 = Cn.Execute(Str)
Debug.Print Rs1.RecordCount
Sheet3.Cells(rr, 1).CopyFromRecordset Rs1
rr = rr + 8
Next ii
Stop
End Sub

复制代码

ning84 · 发表于 2023-6-18 17:33

Sub MustDel1()
Dim Str, sStr, oAddress
Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset, Rs1 As ADODB.Recordset
Set Cn = New ADODB.Connection
Set Rs = New ADODB.Recordset
Set Rs1 = New ADODB.Recordset
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
Str = "Select Distinct F1 From [Sheet2$A1:A6000] Where F1 <> Null"
Rs.Open Str, Cn, adOpenKeyset, adLockOptimistic
Debug.Print Rs.RecordCount
Rs.MoveFirst
For ii = 0 To Rs.RecordCount - 1
Debug.Print Rs.Fields(0)
Rs.MoveNext
Next ii
''
Set Rs1 = Cn.Execute(Str)
Debug.Print Rs.RecordCount
aa = Rs1.GetRows()
Stop
For ii = 0 To 12
Debug.Print aa(0, ii)
Next ii
Stop
End Sub

复制代码

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

[求助] CopyFromRecordset没有实现目标需求。