Iets meer code:
Sub VoerVerwerkingUit()
Dim db As Database
Dim rs1 As Recordset
Dim rs2 As Recordset
Dim Teller As Integer
Dim strSQL As String
Dim varResult As Variant
Set db = CurrentDb()
'Tijdelijke tabel aanmaken
varResult = CopyStruct(db, db, "Tabel1", "TempTabel1", True)
varResult = CopyData(db, db, "Tabel1", "TempTabel1")
Do While DCount("id", "TempTabel1", "Aantal > 0")
Set rs1 = db.OpenRecordset("SELECT * FROM TempTabel1 WHERE Aantal > 0", dbOpenDynaset)
Set rs2 = db.OpenRecordset("SELECT * FROM Tabel2 WHERE Verdeeld IS NULL", dbOpenDynaset)
rs1.MoveFirst
rs2.MoveFirst
Do While Not rs1.EOF
rs2.Edit
rs2![Verdeeld] = rs1![Naam]
rs2.Update
rs1.Edit
rs1![Aantal] = rs1![Aantal] - 1
rs1.Update
rs2.MoveNext
rs1.MoveNext
Loop
Set rs2 = Nothing
Set rs1 = Nothing
Loop
'Tijdelijke tabel weer weggooien
db.TableDefs.Delete "TempTabel1"
Set db = Nothing
MsgBox "Verwerking gereed"
End Sub
Function CopyStruct(from_db As Database, to_db As Database, from_nm As String, to_nm As String, create_ind As Integer) As Integer
On Error GoTo CSErr
Dim i As Integer
Dim tbl As New TableDef 'table object
Dim fld As Field 'field object
Dim ind As Index 'index object
'Search to see if the table exists:
namesearch:
For i = 0 To to_db.TableDefs.Count - 1
If UCase(to_db.TableDefs(i).Name) = UCase(to_nm) Then
If MsgBox(to_nm + " already exists, delete it?", 4) = vbYes Then
to_db.TableDefs.Delete to_nm
Else
to_nm = InputBox("Enter New Table Name:")
If to_nm = "" Then
Exit Function
Else
GoTo namesearch
End If
End If
Exit For
End If
Next
'Strip off owner if necessary:
If InStr(to_nm, ".") <> 0 Then
to_nm = Mid(to_nm, InStr(to_nm, ".") + 1, Len(to_nm))
End If
tbl.Name = to_nm
'Create the fields:
For i = 0 To from_db.TableDefs(from_nm).Fields.Count - 1
Set fld = New Field
fld.Name = from_db.TableDefs(from_nm).Fields(i).Name
fld.Type = from_db.TableDefs(from_nm).Fields(i).Type
fld.Size = from_db.TableDefs(from_nm).Fields(i).Size
fld.Attributes = from_db.TableDefs(from_nm).Fields(i).Attributes
tbl.Fields.Append fld
Next
'Create the indexes:
If create_ind <> False Then
For i = 0 To from_db.TableDefs(from_nm).Indexes.Count - 1
Set ind = New Index
ind.Name = from_db.TableDefs(from_nm).Indexes(i).Name
ind.Fields = from_db.TableDefs(from_nm).Indexes(i).Fields
ind.Unique = from_db.TableDefs(from_nm).Indexes(i).Unique
If gstDataType <> "ODBC" Then
ind.Primary = from_db.TableDefs(from_nm).Indexes(i).Primary
End If
tbl.Indexes.Append ind
Next
End If
'Append the new table:
to_db.TableDefs.Append tbl
CopyStruct = True
GoTo CSEnd
CSErr:
CopyStruct = False
Resume CSEnd
CSEnd:
End Function
Function CopyData(from_db As Database, to_db As Database, from_nm As String, to_nm As String) As Integer
On Error GoTo CopyErr
Dim ds1 As Recordset, ds2 As Recordset
Dim i As Integer
Set ds1 = from_db.OpenRecordset(from_nm, dbOpenDynaset)
Set ds2 = to_db.OpenRecordset(to_nm, dbOpenDynaset)
While ds1.EOF = False
ds2.AddNew
For i = 0 To ds1.Fields.Count - 1
ds2(i) = ds1(i)
Next
ds2.Update
ds1.MoveNext
Wend
CopyData = True
GoTo CopyEnd
CopyErr:
CopyData = False
Resume CopyEnd
CopyEnd:
End Function
