Forum - Πίνακες Διαχωρισμός πίνακα

Forum (https://www.ms-office.gr/forum/)

- Access - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/)

- - [ Πίνακες ] Διαχωρισμός πίνακα (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/2529-diaxorismos-pinaka.html)

Διαχωρισμός πίνακα

Καλημέρα.
Ξέρει κάποιος αν υπάρχει τρόπος να διαχωρίσεις έναν πίνακα σε πολλούς;
Δίνω ένα παράδειγμα.
Έχω έναν πίνακα με 6000 εγγραφές. Ανά 200 εγγραφές περίπου έχουν κοινό δεδομένο σε ένα πεδίο.
Υπάρχει τρόπος να διασπάσω αυτόν τον πίνακα σε πίνακες με βάση αυτό το πεδίο;
ΠΕΔΙΑ:
ID ONOMA EPONYMO OMOADA

Θέλω να σπάσω τον αρχικό πίνακα σε πίνακες με βάση την ομάδα.
π.χ. Στο excel θα έκανα μια ταξινόμηση με βάση την ομάδα και με αντιγραφή και επικόλληση θα δημιουργούσα τα αρχεία.
Το ερώτημά μου είναι, αν υπάρχει κάποιος αυτοματοποιημένος τρόπος για να το κάνω αυτό.
Ευχαριστώ.

Καλησπέρα!
Μάνο, έστω ότι ο πίνακας ονομάζεται "BigTable" και το πεδίο ομαδοποίησης "OMADA"

Ο παρακάτω κώδικας νομίζω ότι θα σε εξυπηρετήσει:

Κώδικας:

Option Compare Database

Option Explicit
 

Sub Test()
 'MainTableName = "το όνομα του πίνακα"

'GroupFieldName = "το όνομα του πεδίου ομαδοποίησης"

'OverWriteTables: True για αντικατάσταση πινάκων με το ίδιο όνομα.

    SplitTable MainTableName:="BigTable", GroupFieldName:="OMADA", OverWriteTables:=True

End Sub
 

Function SplitTable(MainTableName As String, _

                    GroupFieldName As String, _

                    OverWriteTables As Boolean)

    Dim dbs As DAO.Database

    Dim rsTeams As DAO.Recordset

    Dim strSQL As String

    Dim AllTables As DAO.TableDefs

    Dim GroupField As DAO.Field

    Dim NewTableName As String
 

    MainTableName = "[" & MainTableName & "]"

    GroupFieldName = "[" & GroupFieldName & "]"
 

    Set dbs = CurrentDb

    Set AllTables = dbs.TableDefs

    Set rsTeams = dbs.OpenRecordset( _

                  "SELECT DISTINCT " & MainTableName & "." & GroupFieldName & _

                  " FROM " & MainTableName & " WHERE nz(" & GroupFieldName & ","""")<>""""", dbOpenSnapshot)
 

    If rsTeams.RecordCount Then

        Set GroupField = rsTeams.Fields(GroupFieldName)

        rsTeams.MoveFirst

        While Not rsTeams.EOF
 

            NewTableName = Replace(GroupField.Value, " ", "_")

            strSQL = "SELECT " & MainTableName & ".* INTO " & NewTableName

            strSQL = strSQL & " FROM " & MainTableName & " WHERE " _

                     & MainTableName & "." & GroupFieldName & " ='" & GroupField.Value & "'"
 

            If TableExists(AllTables, GroupField.Value) Then

                If OverWriteTables Then

                    AllTables.Delete GroupField.Value

                    AllTables.Refresh

                Else

                    GoTo NextRec

                End If

            End If
 

            dbs.Execute strSQL

            AllTables.Refresh

NextRec:

            rsTeams.MoveNext
 

        Wend
 

        Application.RefreshDatabaseWindow
 

    End If

    rsTeams.Close

    Set rsTeams = Nothing
 

End Function
 

Function TableExists(AllTables As TableDefs, TableName As String)

    Dim tdf As DAO.TableDef

    For Each tdf In AllTables

        If tdf.Name = TableName Then

            TableExists = True

            Exit For

        End If

    Next

End Function

Καλή συνέχεια!

Τάσος

Παράθεση:

Αρχική Δημοσίευση από Tasos (Μήνυμα 14825)

Κώδικας:

Option Compare Database

Option Explicit
 

Sub Test()
 'MainTableName = "το όνομα του πίνακα"

'GroupFieldName = "το όνομα του πεδίου ομαδοποίησης"

'OverWriteTables: True για αντικατάσταση πινάκων με το ίδιο όνομα.

    SplitTable MainTableName:="BigTable", GroupFieldName:="OMADA", OverWriteTables:=True

End Sub
 

Function SplitTable(MainTableName As String, _

                    GroupFieldName As String, _

                    OverWriteTables As Boolean)

    Dim dbs As DAO.Database

    Dim rsTeams As DAO.Recordset

    Dim strSQL As String

    Dim AllTables As DAO.TableDefs

    Dim GroupField As DAO.Field

    Dim NewTableName As String
 

    MainTableName = "[" & MainTableName & "]"

    GroupFieldName = "[" & GroupFieldName & "]"
 

    Set dbs = CurrentDb

    Set AllTables = dbs.TableDefs

    Set rsTeams = dbs.OpenRecordset( _

                  "SELECT DISTINCT " & MainTableName & "." & GroupFieldName & _

                  " FROM " & MainTableName & " WHERE nz(" & GroupFieldName & ","""")<>""""", dbOpenSnapshot)
 

    If rsTeams.RecordCount Then

        Set GroupField = rsTeams.Fields(GroupFieldName)

        rsTeams.MoveFirst

        While Not rsTeams.EOF
 

            NewTableName = Replace(GroupField.Value, " ", "_")

            strSQL = "SELECT " & MainTableName & ".* INTO " & NewTableName

            strSQL = strSQL & " FROM " & MainTableName & " WHERE " _

                     & MainTableName & "." & GroupFieldName & " ='" & GroupField.Value & "'"
 

            If TableExists(AllTables, GroupField.Value) Then

                If OverWriteTables Then

                    AllTables.Delete GroupField.Value

                    AllTables.Refresh

                Else

                    GoTo NextRec

                End If

            End If
 

            dbs.Execute strSQL

            AllTables.Refresh

NextRec:

            rsTeams.MoveNext
 

        Wend
 

        Application.RefreshDatabaseWindow
 

    End If

    rsTeams.Close

    Set rsTeams = Nothing
 

End Function
 

Function TableExists(AllTables As TableDefs, TableName As String)

    Dim tdf As DAO.TableDef

    For Each tdf In AllTables

        If tdf.Name = TableName Then

            TableExists = True

            Exit For

        End If

    Next

End Function

Καλή συνέχεια!

Τάσος

Τάσο κατ' αρχήν σε ευχαριστώ πολύ για την απάντηση σου.
Για να είμαι ειλικρινής δεν το έχω δοκιμάσει ακομά γιατί δεν ξέρω που να βάλω τον παραπάνω κώδικα που μου έστειλες.
Και πάλι ευχαριστώ.

Το βάζω σαν module;

Καλημέρα!
Μάνο, μπορείς να βάλεις τη συνάρτηση SplitTable() σε μια κοινή λειτουργική μονάδα και να την τρέχεις από φόρμα αντιστοιχώντας τις γραμμές του κώδικα της εντολής Test σε ένα κουμπί.

Καλή συνέχεια!Τάσος

Τάσο καλημέρα.
Μου βγάζει ένα μήνυμα
run-time error '3607'
Η είσοδος στο ερώτημα πρέπει να περιέχει τουλάχιστον έναν πίνακα ή ένα ερώτημα.
Όταν κάνω debug
με πάει εδώ
If TableExists(AllTables, GroupField.Value) Then
If OverWriteTables Then
AllTables.Delete GroupField.Value
AllTables.Refresh
Else
GoTo NextRec
End If
End If

dbs.Execute strSQL
AllTables.Refresh
NextRec:
rsTeams.MoveNext
Τι μπορεί να είναι;

Φίλε Τάσο καλησπέρα.
Σου επισυνάπτω μία βάση με έναν πίνακα και 2 πεδία.
Θα μπορούσες να βάλεις τον κώδικα που μου έδωσες να δεις γιατί δεν μου τρέχει;
Σε ευχαριστώ εκ των προτέρων.

Καλησπέρα Μάνο!

Δεν έπρεπε να σου παρουσιάσει αυτό το σφάλμα.

Δοκίμασε το συνημμένο. Σε μένα λειτουργεί κανονικά.

Φιλικά

Τάσος

Βγάζει μη αναγνωρίσιμη μορφή το αρχείο που μου έστειλες.

Τάσο δεν μου ανοίγει το αρχείο που μου έστειλες.
Όταν πάω να το ανοίξω μου λέει μή αναγνωρίσιμη μορφή.