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

[Nasia]

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

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

Στην παρακάτω μορφή αρχείου 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 ή να ανατρέξω σε άλλο πρόγραμμα;

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

Νάσια

[kapetang]

Καλησπέρα

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

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».

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

Γιώργος

[Nasia]

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