Problem to modify an open ADODB recordset in VBA

[Atlas123]

I load the recordset with this qry which is strsql in the vba below

select

' ' as UltimateParent, .....etc etc from.....

Then once the field UltimateParent is in the recordset and it is open I try to modify it like this:

Set Rs1(RsLevel, RsIndex) = New ADODB.Recordset

With Rs1(RsLevel, RsIndex)

.CursorLocation = adUseClient

.CursorType = adUseClient

.LockType = adLockOptimistic

.Open strSQL, ConnACDNV

End With



Do Until Rs1(RsLevel, RsIndex).EOF

Rs1(RsLevel, RsIndex).Fields("UltimateParent").Value = "test"

Rs1(RsLevel, RsIndex).Update

Rs1(RsLevel, RsIndex).MoveNext

Loop

The error comes when I try to set the value of the first record to "test"
The error is: Multiple - step operation generates errors. Check each status value.
How do I make a qry with a hard coded column made on the fly in the select statement and then modify the data in the column with VBA once it is in the open recordset?

 

[CharlesChuckieCharles]

Is this as simple as you have to
Rs1(RsLevel, RsIndex).MoveFirst

 

[Atlas123]

It tested EOF and BOF and both are false so I must be on a valid record already, right?

 

[CharlesChuckieCharles]

You tried it then, ....because BOF and EOF are not records

 

[Atlas123]

Yes, bof and eof are false.

 

[xenou]

It's difficult to see what you are doing with these loops (multiple recordsets?). You probably should post all your code, or at least more of it.

 

[CharlesChuckieCharles]

You tried it then, ....because BOF and EOF are not records

I meant You've tried using Movefirst?

 

[Atlas123]

Hello all, that is all the code. All I want to do is change the value of a field in the recordset that was created in the select statement. I'm surprised how difficult this is? And charles, yes I tried movefirst for you but what's the difference if I'm on the first record or the 10th record? As long as I'm not on BOF or EOF I have a valid error that needs handling.

 

[xenou]

Hi,
Your code is incomplete since there is missing information - values of variables are not set, and we cannot see the select statement. Not all queries are editable so that is one possibility. Also it is not clear if you are using multiple recordsets and that is another possible area of trouble (these can be tricky). If you aren't using multiple recordsets than I don't understand the use of the array to hold the recordset or the reason for calling it an "Ultimate Parent" - parent of what? You are correct it is generally very easy to update a single record in a simple recordset. So there really has to be more to this than meets the eye and I think more information will be helpful for troubleshooting.
ξ

 

[Atlas123]

Thanks Xenou, I'm happy to post it all.

This is the SQL select statement that sits in the text box that gets populated into strsql variable
select
' ' as UltimateParent, 1 as Level, ltrim(rtrim(inmast.fpartno)) Parent, ' _' + ltrim(rtrim(inmast.fpartno)) UniqueParent, inmast.fdescript ParentDesc, ltrim(rtrim(t2.fcomponent)) Child, ltrim(rtrim(inmast.fpartno)) + '_' + ltrim(rtrim(t2.fcomponent)) UniqueChild, t2.fdescript ChildDesc, t2.fqty * 1 fqty, t2.fmeasure, t2.fmatlcost * t2.fqty * 1 Std_Cost, t2.f2matlcost * t2.fqty * 1 Rolled_Cost, t2.flastcost * t2.fqty * 1 Last_Cost, t2.favgcost * t2.fqty * 1 Avg_Cost
from
inmast right join
(select
inboms.fparent, inboms.fcomponent, inmast.fdescript, inmast.fmatlcost fmatlcost, inmast.f2matlcost f2matlcost, inmast.flastcost flastcost, inmast.favgcost favgcost, inboms.fqty, inmast.fmeasure
from
inboms left join inmast on inboms.fcomponent = inmast.fpartno
) as t2
on inmast.fpartno = t2.fparent
where
inmast.fpartno = var


This is the main routine where I have the error.
Sub BOMQryV2()
StartTime = Timer

Application.Calculation = xlCalculationManual


ConnectACDNV
Dim Rs1() As ADODB.Recordset
Dim strSQL As String
Dim QryPart As String
Dim OldQryPart As String
Dim InputSheet As Worksheet
Dim OutputSheet As Worksheet
Dim RsLevel As Integer
Dim RsIndex As Integer
Dim Level As String
Dim UniqueParent As String
Dim LastRow As Long
Dim MemoryLevel As Integer
Dim MemoryIndex As Integer
chkhead = True
repeater = True
RsLevel = 1
RsIndex = 1

Set InputSheet = ActiveWorkbook.Sheets("Sheet1")
Set OutputSheet = ActiveWorkbook.Sheets("Sheet2")
OutputSheet.Select
OutputSheet.Cells.Clear

MemoryLevel = 1
MemoryIndex = 1
Multp = "* 1"
QryPart = "inmast.fpartno = '" & InputSheet.Cells(1, 2).Value & "'"
Level = "1 as Level"
UniqueParent = "' _'"
strSQL = Sheets("Property").TextBoxes("TextBox 1").Text
strSQL = Replace(strSQL, "inmast.fpartno = var", QryPart)
ReDim Preserve Rs1(15, 50)

Do Until repeater = False
Set Rs1(RsLevel, RsIndex) = New ADODB.Recordset
With Rs1(RsLevel, RsIndex)
.CursorLocation = adUseClient
.CursorType = adOpenDynamic 'adUseClient adOpenKeyset
.LockType = adLockOptimistic 'adLockReadOnly
.Open strSQL, ConnACDNV
End With

Do Until Rs1(RsLevel, RsIndex).EOF
Rs1(RsLevel, RsIndex).Fields("UltimateParent").Value = " a"
Rs1(RsLevel, RsIndex).Update
Rs1(RsLevel, RsIndex).MoveNext
Loop
Rs1(RsLevel, RsIndex).MoveFirst

If chkhead = True Then
Dim fldCount As Integer
Dim iCol As Integer
fldCount = Rs1(RsLevel, RsIndex).Fields.Count
For iCol = 1 To fldCount
ActiveSheet.Cells(1, iCol).Value = Rs1(RsLevel, RsIndex).Fields(iCol - 1).Name
Next
chkhead = False
End If





Select Case Rs1(RsLevel, RsIndex).RecordCount
Case Is = 0
Set Rs1(RsLevel, RsIndex) = Nothing
Rs1(MemoryLevel, MemoryIndex).MoveNext
If Rs1(MemoryLevel, MemoryIndex).EOF Then
NextRs:
If Rs1(MemoryLevel, MemoryIndex + 1) Is Nothing Then
If Rs1(MemoryLevel + 1, 1) Is Nothing Then GoTo timetest
MemoryLevel = MemoryLevel + 1
MemoryIndex = 1
RsLevel = MemoryLevel + 1
j = 1
On Error GoTo exitloop2:
Do Until Rs1(RsLevel, j) Is Nothing
j = j + 1
Loop
exitloop2:
Resume 2
2:
On Error GoTo 0
RsIndex = j
j = 1
Rs1(MemoryLevel, MemoryIndex).MoveNext
If Rs1(MemoryLevel, MemoryIndex).EOF Then GoTo NextRs
OldQryPart = QryPart
OldMultp = Multp
Multp = "* " & Rs1(MemoryLevel, MemoryIndex).Fields("fqty")
QryPart = "inmast.fpartno = '" & Rs1(MemoryLevel, MemoryIndex).Fields("Child") & "'"
OldUniqueParent = UniqueParent
UniqueParent = "'" & Rs1(MemoryLevel, MemoryIndex).Fields("Parent") & "_'"
Oldlevel = Level
Level = RsLevel & " as Level"
strSQL = Replace(strSQL, OldMultp, Multp)
strSQL = Replace(strSQL, OldQryPart, QryPart)
strSQL = Replace(strSQL, Oldlevel, Level)
strSQL = Replace(strSQL, OldUniqueParent, UniqueParent)
If UBound(Rs1, 2) < RsIndex Then
ReDim Preserve Rs1(15, RsIndex)
End If
Else
MemoryIndex = MemoryIndex + 1
RsLevel = MemoryLevel + 1
j = 1
On Error GoTo exitloop4:
Do Until Rs1(RsLevel, j) Is Nothing
j = j + 1
Loop
exitloop4:
Resume 4
4:
On Error GoTo 0
RsIndex = j
j = 1
Rs1(MemoryLevel, MemoryIndex).MoveNext
If Rs1(MemoryLevel, MemoryIndex).EOF Then GoTo NextRs
OldMultp = Multp
Multp = "* " & Rs1(MemoryLevel, MemoryIndex).Fields("fqty")
OldQryPart = QryPart
QryPart = "inmast.fpartno = '" & Rs1(MemoryLevel, MemoryIndex).Fields("Child") & "'"
OldUniqueParent = UniqueParent
UniqueParent = "'" & Rs1(MemoryLevel, MemoryIndex).Fields("Parent") & "_'"
Oldlevel = Level
Level = RsLevel & " as Level"
strSQL = Replace(strSQL, OldMultp, Multp)
strSQL = Replace(strSQL, OldQryPart, QryPart)
strSQL = Replace(strSQL, Oldlevel, Level)
strSQL = Replace(strSQL, OldUniqueParent, UniqueParent)
If UBound(Rs1, 2) < RsIndex Then
ReDim Preserve Rs1(15, RsIndex)
End If
End If
Else
RsLevel = MemoryLevel
RsIndex = MemoryIndex
OldMultp = Multp
Multp = "* " & Rs1(RsLevel, RsIndex).Fields("fqty")
OldQryPart = QryPart
QryPart = "inmast.fpartno = '" & Rs1(RsLevel, RsIndex).Fields("Child") & "'"
OldUniqueParent = UniqueParent
UniqueParent = "'" & Rs1(RsLevel, RsIndex).Fields("Parent") & "_'"
Oldlevel = Level
RsLevel = MemoryLevel + 1
j = 1
On Error GoTo exitloop1:
Do Until Rs1(RsLevel, j) Is Nothing
j = j + 1
Loop
exitloop1:
Resume 1
1:
On Error GoTo 0
RsIndex = j
j = 1
Level = RsLevel & " as Level"
strSQL = Replace(strSQL, OldMultp, Multp)
strSQL = Replace(strSQL, OldQryPart, QryPart)
strSQL = Replace(strSQL, Oldlevel, Level)
strSQL = Replace(strSQL, OldUniqueParent, UniqueParent)
If UBound(Rs1, 2) < RsIndex Then
ReDim Preserve Rs1(15, RsIndex)
End If

End If

Case Is <> 0
LastRow = OutputSheet.UsedRange.Rows.Count
ActiveSheet.Cells(LastRow + 1, 1).CopyFromRecordset Rs1(RsLevel, RsIndex)
Rs1(RsLevel, RsIndex).MoveFirst
OldMultp = Multp
Multp = "* " & Rs1(RsLevel, RsIndex).Fields("fqty")
OldQryPart = QryPart
QryPart = "inmast.fpartno = '" & Rs1(RsLevel, RsIndex).Fields("Child") & "'"
OldUniqueParent = UniqueParent
UniqueParent = "'" & Rs1(RsLevel, RsIndex).Fields("Parent") & "_'"
Oldlevel = Level
RsLevel = RsLevel + 1
j = 1
On Error GoTo exitloop3:
Do Until Rs1(RsLevel, j) Is Nothing
j = j + 1
Loop
exitloop3:
Resume 3
3:
On Error GoTo 0
RsIndex = j
j = 1
Level = RsLevel & " as Level"
strSQL = Replace(strSQL, OldMultp, Multp)
strSQL = Replace(strSQL, OldQryPart, QryPart)
strSQL = Replace(strSQL, Oldlevel, Level)
strSQL = Replace(strSQL, OldUniqueParent, UniqueParent)
End Select
If 1 = 1 Then
End If

Loop

timetest:



Erase Rs1

CloseACDNV
Application.Calculation = xlCalculationAutomatic
'handle over 15 levels
OutputSheet.Columns("a").Insert
ActiveWorkbook.Names("Children").RefersTo = "=OFFSET(Sheet2!$G$2,0,0,COUNTA(Sheet2!$G:$G)-1,1)"
ActiveWorkbook.Names("Parents").RefersTo = "=OFFSET(Sheet2!$D$2,0,0,COUNTA(Sheet2!$D:$D)-1,1)"
ActiveWorkbook.Names("SimuRoll").RefersTo = "=OFFSET(Sheet2!$O$2,0,0,COUNTA(Sheet2!$O:$O)-1,1)"
OutputSheet.Cells(1, 1) = "Ultimate Parent"
OutputSheet.Cells(1, 15) = "SimuRoll"
LastRow = OutputSheet.UsedRange.Rows.Count
With Range("A2:A" & LastRow)
.Formula = "=FindParent(G2,Children,Parents,B2,1)"
.Value = .Value
End With
With Range("O2:O" & LastRow)
.Formula = "=IF(ISERROR(MATCH(G2,Parents,0)),K2,SUMIF(Parents,G2,SimuRoll)*I2)"
'.Value = .Value
End With

Application.Calculate
ActiveCell.Columns("A:M").EntireColumn.EntireColumn.AutoFit
r = 2
Do Until r = LastRow + 1
Dim Sortcell As Object
Dim Sortunder As Object
Set Sortcell = Cells(r, 4)
Set Sortunder = Range("Children").Find(what:=Sortcell, after:=OutputSheet.Cells(Sortcell.Row, Sortcell.Column + 3), LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not Sortunder Is Nothing Then
Set Sortunder = Sortunder.Offset(1, 0)
If Sortcell.Row = Sortunder.Row Then
r = r + 1
Else
Sortcell.EntireRow.Cut
Sortunder.EntireRow.Insert Shift:=xlDown
Set Sortunder = Nothing
r = r + 1
End If
Else
r = r + 1
End If
Loop


EndTime = Timer - StartTime
MsgBox (EndTime)
End Sub


This is the routine that the main routine calls to make the connection to sql server 2008


Public ConnACDNV
Public ACDNVConString As String

Sub ConnectACDNV()
Set ConnACDNV = CreateObject("ADODB.Connection")
ACDNVConString = "Provider=SQLOLEDB.1;Server=10.128.30.240;Database=M2MDATA30;Trusted_Connection=yes;"
ConnACDNV.ConnectionString = ACDNVConString
If ConnACDNV.State = adStateClosed Then
ConnACDNV.Open
End If
End Sub