Forum - Εξαγωγή πινάκα σε αρχείο asci με συγκεκριμένη μορφή

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

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

- - Εξαγωγή πινάκα σε αρχείο asci με συγκεκριμένη μορφή (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/3101-eksagogi-pinaka-se-arxeio-asci-me-sygkekrimeni-morfi.html)

Εξαγωγή πινάκα σε αρχείο asci με συγκεκριμένη μορφή

Καλησπέρα σας! :038:

Θα ήθελα να ρωτήσω αν έχει δυνατότητα η VBA να εξάγει 3 πίνακες σε ένα αρχείο asci της παρακάτω μορφής.
Σας στέλνω και την υποτιθέμενη βάση PELATES.zip (η οποία δημιουργήθηκε με την πολύτιμη βοήθεια ενός χρήστη του forum :yahoo:) ώστε να δείτε τους πίνακες.

Στην παρακάτω μορφή αρχείου asci εμφανίζονται οι «Εξετάσεις» (με αλφαβητική σειρά) ως τίτλοι ανάμεσα στα #00 και από κάτω ακολουθούν οι «Πελάτες» που αναλαμβάνουν αυτήν την εξέταση με το Ονοματεπώνυμό τους να βρίσκεται ανάμεσα σε #01 και με το σταθερό λεκτικό «Ονοματεπώνυμο:» μπροστά από το πεδίο. Η Διεύθυνση να βρίσκεται ανάμεσα σε #02 με το σταθερό λεκτικό «Διεύθυνση:» μπροστά από το πεδίο και το Τηλέφωνο να βρίσκεται ανάμεσα σε #02 με το σταθερό λεκτικό «Τηλ:» μπροστά από το πεδίο.
(Τα bold γράμματα τα έκανα επίτηδες για να γίνει λίγο πιο ξεκάθαρο)

#00 Holter αρτηριακής πίεσης#00
#01 Ονοματεπώνυμο: ΑΘΑΝΑΣΙΟΥ ΓΕΩΡΓΙΟΣ #01
#02 Διεύθυνση: Κωνσταντινουπόλεως 5#02
#02 Τηλ. 2107777777#02
#01 Ονοματεπώνυμο: ΠΕΡΡΑΚΗΣ ΚΩΝΣΤΑΝΤΙΝΟΣ#01
#02 Διεύθυνση: Σίφνου 57#02
#02 Τηλ. 2104444444#02
#00 Triplex καρδιάς#00
#01 Ονοματεπώνυμο: ΠΑΠΑΔΟΠΟΥΛΟΣ ΔΗΜΗΤΡΙΟΣ#01
#02 Διεύθυνση: Κολοκοτρώνη 60#02
#02 Τηλ. 2105555555#02
#00 Καρδιογράφημα#00
#01 Ονοματεπώνυμο: ΑΘΑΝΑΣΙΟΥ ΓΕΩΡΓΙΟΣ #01
#02 Διεύθυνση: Κωνσταντινουπόλεως 5#02
#02 Τηλ. 2107777777#02
#01 Ονοματεπώνυμο: ΠΕΡΡΑΚΗΣ ΚΩΝΣΤΑΝΤΙΝΟΣ#01
#02 Διεύθυνση: Σίφνου 57#02
#02 Τηλ. 2104444444#02
#00 Μαγνητική τομογραφία#00
#01 Ονοματεπώνυμο: ΚΑΝΕΛΟΠΟΥΛΟΣ ΑΘΑΝΑΣΙΟΣ#01
#02 Διεύθυνση: Λεωφ. Αλεξάνδρας 145#02
#02 Τηλ. 2103333333#02
#00 ……. κλπ

Υπάρχει η δυνατότητα να γίνει το παραπάνω με VBA ή να ανατρέξω σε άλλο πρόγραμμα; :confused1:

Ευχαριστώ πολύ!

Νάσια

Καλησπέρα

Νάσια, στο επισυναπτόμενο αρχείο:

1) Έχω προσθέσει το ερώτημα qryExport, το οποίο περιέχει τα δεδομένα που θα εξαχθούν στο αρχείο κειμένου.

2) Τη φόρμα frmExport.

Πατώντας το κουμπί [Εξαγωγή Δεδομένων] της φόρμας, εκτελείται ο παρακάτω κώδικας που υλοποιεί το ζητούμενο.

Κώδικας:

Private Sub cmdExport_Click()

    'Απαιτείται αναφορά στο Microsofrt Scripting Runtime

    

    Dim numRec As Long, rsE As DAO.Recordset, rsP As DAO.Recordset

    Dim strSQL As String, strExit As String

    Dim fso As Object, oFile As Object, strFile As String

    Dim j As Long, strExport As String

    

    On Error GoTo Err_Trap

    

    'Εδώ καθορίζεται το αρχείο στο οποίο θα εξαχθούν τα δεδομένα

    strFile = "C:\EXETASEIS.txt"
     

    strSQL = "SELECT DISTINCT [Kwdikos_Exetashs],[Perigrafh_Exetashs] FROM qryExport ORDER BY Perigrafh_Exetashs"

    Set rsE = CurrentDb.OpenRecordset(strSQL)

    

    If rsE.RecordCount > 0 Then

        numRec = rsE.RecordCount + DCount("*", "qryExport") * 3

        ReDim strrec(1 To numRec) As String

        rsE.MoveFirst

        

        'Εδώ λαμβάνονται τα δεδομένα από το ερώτημα qryExport

        'και αποθηκεύονται στα στοιχεία του μονοδιάστατου πίνακα strRec()

        Do Until rsE.EOF

            strSQL = "SELECT [Perigrafh_Exetashs],[Onomateponymo], [Dieythinsh] ,[Thlefwno] " _

            & "FROM qryExport WHERE [Kwdikos_Exetashs]=" & rsE![Kwdikos_Exetashs] _

            & " ORDER BY [Onomateponymo]"

            Set rsP = CurrentDb.OpenRecordset(strSQL)

            rsP.MoveFirst

            j = j + 1: strrec(j) = "#00 " & rsP![Perigrafh_Exetashs] & " #00"

            Do Until rsP.EOF

                j = j + 1: strrec(j) = "#01 Ονοματεπώνυμο: " & rsP![Onomateponymo] & " #01"

                j = j + 1: strrec(j) = "#02 Διεύθυνση: " & rsP![Dieythinsh] & " #02"

                j = j + 1: strrec(j) = "#02 Τηλ: " & rsP![Thlefwno] & " #02"

                rsP.MoveNext

            Loop

            rsP.Close

            rsE.MoveNext

        Loop

        

        'Όλα τα στοιχεία του πίνακα ενώνονται στο string strExport

        'και το string αποθηκεύεται στο αρχείο κειμένου strFile

        

        strExport = Join(strrec, vbCrLf)

        Set fso = CreateObject("scripting.FileSystemObject")

        Set oFile = fso.CreateTextFile(strFile)

        oFile.WriteLine strExport

        MsgBox "Η εξαγωγή των δεδομέμων ολοκληρώθηκε." & vbCrLf & "Αρχείο: " & strFile

    End If

    

Exit_Sub:

On Error Resume Next

    oFile.Close

    rsE.Close

    rsP.Close

    Set fso = Nothing

    Exit Sub

    

Err_Trap:

    MsgBox "Error: #" & Err.Number & vbCrLf & Err.Description, "Error"

    Resume Exit_Sub

End Sub

Το αρχείο στο οποίο αποθηκεύονται, ως κείμενο, τα δεδομένα είναι το «C:\EXETASEIS.txt».

Μπορείς να το αλλάξεις τροποποιώντας τη σχετική γραμμή του κώδικα.

Γιώργος

Σ' ευχαριστώ (και πάλι) Γιώργο για την άμεση απάντησή σου αλλά και για τον χρόνο που αφιέρωσες!!! Είναι αυτό που ζητούσα!!!!!!!!!!!! :yahoo: