Forum

Αναζήτηση στο ms-office.gr

Πάμε!
ms-office.gr > Forum > Microsoft Access > Access - Ερωτήσεις / Απαντήσεις > [ Πίνακες ] Διαχωρισμός πίνακα

Access - Ερωτήσεις / Απαντήσεις Access + VBA... Εδώ δεν υπάρχουν όρια!

Απάντηση στο θέμα

 

Εργαλεία Θεμάτων Τρόποι εμφάνισης
  #1  
Παλιά 21-05-13, 09:55
Όνομα: Μάνος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 10-10-2012
Μηνύματα: 83
Προεπιλογή Διαχωρισμός πίνακα

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

Θέλω να σπάσω τον αρχικό πίνακα σε πίνακες με βάση την ομάδα.
π.χ. Στο excel θα έκανα μια ταξινόμηση με βάση την ομάδα και με αντιγραφή και επικόλληση θα δημιουργούσα τα αρχεία.
Το ερώτημά μου είναι, αν υπάρχει κάποιος αυτοματοποιημένος τρόπος για να το κάνω αυτό.
Ευχαριστώ.
Απάντηση με παράθεση
  #2  
Παλιά 21-05-13, 15:50
Το avatar του χρήστη Tasos
Διαχειριστής
Όνομα: Τάσος Φιλοξενιδης
Έκδοση λογισμικού Office: Ms-Office 2016, Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική, Γερμανική
 
Εγγραφή: 21-10-2009
Μηνύματα: 2.237
Προεπιλογή

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

Τάσος
__________________
Ms-Office Development Team
Ανάπτυξη επαγγελματικών εφαρμογών

Τελευταία επεξεργασία από το χρήστη Tasos : 21-05-13 στις 19:59.
Απάντηση με παράθεση
  #3  
Παλιά 23-05-13, 20:04
Όνομα: Μάνος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 10-10-2012
Μηνύματα: 83
Προεπιλογή

Παράθεση:
Αρχική Δημοσίευση από 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
Καλή συνέχεια!

Τάσος
Τάσο κατ' αρχήν σε ευχαριστώ πολύ για την απάντηση σου.
Για να είμαι ειλικρινής δεν το έχω δοκιμάσει ακομά γιατί δεν ξέρω που να βάλω τον παραπάνω κώδικα που μου έστειλες.
Και πάλι ευχαριστώ.
Απάντηση με παράθεση
  #4  
Παλιά 24-05-13, 05:08
Όνομα: Μάνος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 10-10-2012
Μηνύματα: 83
Προεπιλογή

Το βάζω σαν module;
Απάντηση με παράθεση
  #5  
Παλιά 24-05-13, 06:18
Το avatar του χρήστη Tasos
Διαχειριστής
Όνομα: Τάσος Φιλοξενιδης
Έκδοση λογισμικού Office: Ms-Office 2016, Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική, Γερμανική
 
Εγγραφή: 21-10-2009
Μηνύματα: 2.237
Προεπιλογή

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

Καλή συνέχεια!Τάσος
__________________
Ms-Office Development Team
Ανάπτυξη επαγγελματικών εφαρμογών
Απάντηση με παράθεση
  #6  
Παλιά 28-05-13, 10:44
Όνομα: Μάνος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 10-10-2012
Μηνύματα: 83
Προεπιλογή

Τάσο καλημέρα.
Μου βγάζει ένα μήνυμα
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
Τι μπορεί να είναι;
Απάντηση με παράθεση
  #7  
Παλιά 03-06-13, 19:55
Όνομα: Μάνος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 10-10-2012
Μηνύματα: 83
Προεπιλογή

Φίλε Τάσο καλησπέρα.
Σου επισυνάπτω μία βάση με έναν πίνακα και 2 πεδία.
Θα μπορούσες να βάλεις τον κώδικα που μου έδωσες να δεις γιατί δεν μου τρέχει;
Σε ευχαριστώ εκ των προτέρων.
Συνημμένα Αρχεία
Τύπος Αρχείου: accdb TEST.accdb (396,0 KB, 9 εμφανίσεις)
Απάντηση με παράθεση
  #8  
Παλιά 03-06-13, 22:19
Το avatar του χρήστη Tasos
Διαχειριστής
Όνομα: Τάσος Φιλοξενιδης
Έκδοση λογισμικού Office: Ms-Office 2016, Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική, Γερμανική
 
Εγγραφή: 21-10-2009
Μηνύματα: 2.237
Προεπιλογή

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

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

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

Φιλικά

Τάσος
Συνημμένα Αρχεία
Τύπος Αρχείου: accdb Database1.accdb (456,0 KB, 22 εμφανίσεις)
__________________
Ms-Office Development Team
Ανάπτυξη επαγγελματικών εφαρμογών

Τελευταία επεξεργασία από το χρήστη Tasos : 04-06-13 στις 11:03.
Απάντηση με παράθεση
  #9  
Παλιά 03-06-13, 22:44
Όνομα: Μάνος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 10-10-2012
Μηνύματα: 83
Προεπιλογή

Βγάζει μη αναγνωρίσιμη μορφή το αρχείο που μου έστειλες.
Απάντηση με παράθεση
  #10  
Παλιά 03-06-13, 23:02
Όνομα: Μάνος
Έκδοση λογισμικού Office: Ms-Office 2007
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 10-10-2012
Μηνύματα: 83
Προεπιλογή

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

Εργαλεία Θεμάτων
Τρόποι εμφάνισης

Δικαιώματα - Επιλογές
Δε μπορείτε να δημοσιεύσετε νέα μηνύματα
Δε μπορείτε να δημοσιεύσετε απαντήσεις
Δεν μπορείτε να επισυνάψετε αρχεία
Δεν μπορείτε να επεξεργαστείτε τα μηνύματα σας

Ο κώδικας ΒΒ είναι σε λειτουργία
Τα Smilies είναι σε λειτουργία
Ο κώδικας [IMG] είναι σε λειτουργία
Ο κώδικας HTML είναι εκτός λειτουργίας
Trackbacks are εκτός λειτουργίας
Pingbacks are εκτός λειτουργίας
Refbacks are εκτός λειτουργίας


Παρόμοια Θέματα

Θέμα Δημιουργός Forum Απαντήσεις Τελευταίο Μήνυμα
[Συναρτήσεις] Διαχωρισμός ενός αριθμού. Niha Excel - Ερωτήσεις / Απαντήσεις 3 11-08-15 08:49
[ Ερωτήματα ] Διαχωρισμός Πεδίου σε πεδία jimrenoir Access - Ερωτήσεις / Απαντήσεις 2 18-12-14 17:51
[Γενικά] Διαχωρισμός σε φύλλα Θανάσης Excel - Ερωτήσεις / Απαντήσεις 12 14-05-11 15:45
[ Εκθέσεις ] Διαχωρισμός ονοματεπώνυμου mgeorge Access - Ερωτήσεις / Απαντήσεις 6 08-05-11 00:45
Διαχωρισμός δεδομένων πεδίου JohnD Access - Ερωτήσεις / Απαντήσεις 13 08-09-10 14:43


Η ώρα είναι 04:25.