Εστω ενας πινακας με τρια πεδια F1,F2,F3.
Αν καθε πινακας αντιστοιχει σε μια μερα του χρονου (π.χ. 01_01_13,
02_01_13 κλπ) πως μπορουμε να τους εμφανισουμε ολους μαζι μαζι τους πινακες ενος ετους(365) σε εναν ενιαιο πινακα;.
Πολαπλοι πινακες
Συντονιστές: WebDev Moderators, Super-Moderators
Πολαπλοι πινακες
Το κάνεις copy μεσα σ ενα module και το τρέχεις ή μεσα στο module ή με ενα κουμπι σε μια φόρμα στο on click event καλεις την function με
Call newfunction
ALL το όνομα του Πίνακα που θα μαζεψεις όλες τις εγγραφες
Προσοχη η βαση σου να περιεχει μονο τους πινακες που θες να μαζεψεις και τον ALL
Εννοειται πως ολοι οι πινακες θα εχουν ακριβως ίδια δομή με τα τρια πεδια F1,F2,F3. Eπισης αν το τρεξεις πανω απο μια φορα να αδειαζεις τον κεντρικο πινακα
Function newfunction()
Dim db As Database
Dim def As TableDef
Dim str As String
Dim newrs As Recordset
Dim oldrs As Recordset
Set db = CurrentDb
Set newrs = db.OpenRecordset("ALL")
For Each def In db.TableDefs
str = def.Name
If str <> "ALL" And Left(str, 4) <> "MSys" Then
Set oldrs = db.OpenRecordset(str)
With oldrs
oldrs.MoveFirst
Do
newrs.AddNew
newrs.Fields(0).Value = oldrs.Fields(0).Value
newrs.Fields(1).Value = oldrs.Fields(1).Value
newrs.Fields(2).Value = oldrs.Fields(2).Value
oldrs.MoveNext
newrs.Update
Loop While Not oldrs.EOF
oldrs.Close
End With
End If
Next def
Set oldrs = Nothing
Set newrs = Nothing
Set db = Nothing
End Function
Call newfunction
ALL το όνομα του Πίνακα που θα μαζεψεις όλες τις εγγραφες
Προσοχη η βαση σου να περιεχει μονο τους πινακες που θες να μαζεψεις και τον ALL
Εννοειται πως ολοι οι πινακες θα εχουν ακριβως ίδια δομή με τα τρια πεδια F1,F2,F3. Eπισης αν το τρεξεις πανω απο μια φορα να αδειαζεις τον κεντρικο πινακα
Function newfunction()
Dim db As Database
Dim def As TableDef
Dim str As String
Dim newrs As Recordset
Dim oldrs As Recordset
Set db = CurrentDb
Set newrs = db.OpenRecordset("ALL")
For Each def In db.TableDefs
str = def.Name
If str <> "ALL" And Left(str, 4) <> "MSys" Then
Set oldrs = db.OpenRecordset(str)
With oldrs
oldrs.MoveFirst
Do
newrs.AddNew
newrs.Fields(0).Value = oldrs.Fields(0).Value
newrs.Fields(1).Value = oldrs.Fields(1).Value
newrs.Fields(2).Value = oldrs.Fields(2).Value
oldrs.MoveNext
newrs.Update
Loop While Not oldrs.EOF
oldrs.Close
End With
End If
Next def
Set oldrs = Nothing
Set newrs = Nothing
Set db = Nothing
End Function
Μέλη σε σύνδεση
Μέλη σε αυτήν τη Δ. Συζήτηση: Δεν υπάρχουν εγγεγραμμένα μέλη και 1 επισκέπτης