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

[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

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

Τάσος