求教一个数据库的问题.

joed

hi.
这道题终于有个眉目了:
在窗体上设立4个按键:
Gesamt_Auflistung, Stufen_Auflistung, Übersichts_Auflistung, Neuanlage tblZielTest

然后输入如下代码就行了:

Option Compare Database
Option Explicit
Dim bGefunden As Boolean
Dim bEnde As Boolean
Dim RettSchluessel(99)
Dim RettOberElement(99) As String
Dim RettMultiplikator(99) As Integer

Dim iStufe As Integer
Dim i As Integer

Dim stDocName As String

Dim OrigRst As DAO.Recordset
Dim ZielRst As DAO.Recordset

Private Sub Gesamt_Auflistung_Click()
        
    Bearb_Ziel
    stDocName = "rptZiel_Gesamt"
    DoCmd.OpenReport stDocName, acViewPreview

End Sub

Private Sub Bearb_Ziel()
    bGefunden = False
    bEnde = False
        
    Set OrigRst = CurrentDb.OpenRecordset("tblOriginal")
    Set ZielRst = CurrentDb.OpenRecordset("tblZiel")
               
    ' Loesche Zieltabelle "besonders quick and dirty"
    Do Until ZielRst.EOF
        ZielRst.Delete
        ZielRst.MoveNext
    Loop
   
    iStufe = 0
    RettMultiplikator(iStufe) = 1
   
    ' Lesen o-Datei mit Formularkey
   
    OrigRst.Index = "OberElement"
   
    OrigRst.Seek "=", Me.OberElement
   
    If OrigRst.NoMatch Then
        bEnde = True
    Else
        bGefunden = True
    End If
   
    Do Until bEnde
        If bGefunden Then
            ' Schreiben Zieltabelle
            ZielRst.AddNew
            ZielRst!UnterElement = OrigRst!UnterElement
            ZielRst!OrigAnzahl = OrigRst!Anzahl
            If iStufe = 0 Then
                ZielRst!Anzahl = OrigRst!Anzahl
            Else
                ZielRst!Anzahl = OrigRst!Anzahl
                'Multiplikation der Mengen mit den Vorstufen
                For i = iStufe To 1 Step -1
                   ZielRst!Anzahl = ZielRst!Anzahl * RettMultiplikator(iStufe - i)
                Next
            End If
            ZielRst!Stufe = iStufe
            
            ZielRst.Update
            
            RettSchluessel(iStufe) = OrigRst.Bookmark
            RettOberElement(iStufe) = OrigRst!OberElement
            RettMultiplikator(iStufe) = OrigRst!Anzahl
        End If
        
        ' Lesen Orig-Datei mit UE-Schluessel
        
        OrigRst.Seek "=", OrigRst!UnterElement
        
        If OrigRst.NoMatch Then
            AltePosUndNaechsten
        Else
            bGefunden = True
            iStufe = iStufe + 1
        End If
                       
    Loop
        
OrigRst.Close
ZielRst.Close

End Sub

Private Sub AltePosUndNaechsten()
    bEnde = False
    bGefunden = False
   
    Do Until bEnde = True Or bGefunden = True
   
        OrigRst.Bookmark = RettSchluessel(iStufe)
        OrigRst.MoveNext
        If Not OrigRst.EOF Then
            If OrigRst!OberElement = RettOberElement(iStufe) Then
                bGefunden = True
            Else
                If iStufe > 0 Then
                    iStufe = iStufe - 1
                Else
                   bEnde = True
                End If
            End If
        Else
            If iStufe > 0 Then
                iStufe = iStufe - 1
            Else
                bEnde = True
            End If
        End If
    Loop
   
End Sub

Private Sub Neuanlage_Click()
   
     ' Neuanlage tblZielTest
    Dim conn As ADODB.Connection
    Dim Info As Integer
   
    Set conn = CurrentProject.Connection
        ' Pruefung des Zustandes eines Datenbankobjektes
    '       0 = nicht geoeffnet oder nicht vorhanden
    '       1 = geoeffnet
    '       2 = geaendert, aber nicht gespeichertacSysCmdGetObjectState
    '       4 = Neu
    Info = SysCmd(acSysCmdGetObjectState, acTable, "tblZielTest")
   
    'Select Case Info
    'Case Is = 0
        ' Datei nicht vorhanden
    '    conn.Execute "DROP TABLE tblZielTest"
    'Case Is = 1
    '    conn.Execute "DROP TABLE tblZielTest"
    'Case Else
    '    MsgBox "Die Tabelle tblZielTest kann nicht geloescht werden"
    'End Select
   
    On Error GoTo Fehler
    conn.Execute "DROP TABLE tblZielTest"
   
    conn.Execute "CREATE TABLE tblZielTest " _
            & "(Autowert Counter, " _
            & "Unterelement char(10), " _
            & "Anzahl Integer, " _
            & "OrigAnzahl integer)"
   
    Set conn = Nothing
   
    GoTo FehlerEnde
   
Fehler:
    Select Case Err.Number
    Case Is = -2147217865
        MsgBox "Datei war nicht vorhanden"
        Resume Next
    Case Else
        Resume Next
    End Select
   
FehlerEnde:
   
End Sub

Private Sub Stufen_Auflistung_Click()
   
    Bearb_Ziel
    stDocName = "rptZiel_Stufe"
    DoCmd.OpenReport stDocName, acViewPreview

End Sub

Private Sub Uebersichts_Auflistung_Click()
   
    Bearb_Ziel
    stDocName = "rptZiel_uebersicht"
    DoCmd.OpenReport stDocName, acViewPreview
   
End Sub
$ok$