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

[gaz_manos]

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

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

[Tasos]

Καλησπέρα!
Μάνο, έστω ότι ο πίνακας ονομάζεται "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

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

Τάσος

[gaz_manos]

Αρχική Δημοσίευση από Tasos

Καλησπέρα!
Μάνο, έστω ότι ο πίνακας ονομάζεται "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

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

Τάσος

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

[gaz_manos]

Το βάζω σαν module;

[Tasos]

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

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

[gaz_manos]

Τάσο καλημέρα.
Μου βγάζει ένα μήνυμα
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
Τι μπορεί να είναι;

[gaz_manos]

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

[Tasos]

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

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

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

Φιλικά

Τάσος

[gaz_manos]

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

[gaz_manos]

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