[Γενικά] δημιουργία αρχείων word απο κελιά του excel

[jimis]

Καλησπέρα και Χρόνια πολλά!

Για άλλη μια φορά θέλω την βοήθεια σας σε κάτι που προσπαθώ να κάνω που είναι λίγο περίπλοκο. Έχω ένα excel με μοναδικές ονομασίες στην στήλη Α (στο σύνολο περίπου 300 και πιθανόν στο μέλλον να προστεθούν και άλλα) και κάποιους αριθμούς στην στήλη Β. Αυτό που θέλω να πετύχω είναι να δημιουργούνται αυτόματα σε έναν φάκελο τόσα αρχεία word όσα και τα ονόματα στη στήλη Α με την αντίστοιχη ονομασία (δηλαδή αν το Α2 γράφει αστδφ και το word να ονομάζεται αστδφ) που θα αντιστοιχούν με υπερσύνδεσμο από τα κελιά του excel . Επιπλέον αν μπορεί να γίνει τα word να έχουν μια συγκεκριμένη μορφή από ένα πρότυπο που έχω δημιουργήσει (κουμπί office > δημιουργία > τα πρότυπα μου > δημιουργία νέου > πρότυπου > αποθήκευση στο C:\Users\Administrator\AppData\Roaming\Microsoft\� �ρότυπα). Γνωρίζεται αν μπορεί να γίνει κάτι τέτοιο ή ο μόνος τρόπος είναι με το χέρι ένα ένα;

Ευχαριστώ πολύ και με το καλό να έρθει το νέο έτος!

[Spirosgr]

Καλησπέρα και Χρόνια πολλά!
Ο κώδικας πιο κάτω, κάνει το εξής:

Έστω ένα αρχείο Word, με όνομα This is a test.dotx
*η κατάληξη μπορεί να είναι οτιδήποτε
Έστω ένα αρχείο Excel, με όνομα Book1.xlsm
*η κατάληξη μπορεί να είναι οτιδήποτε μπορεί να διαχειριστεί μακροεντολές

Στο αρχείο Excel, στην πρώτη στήλη, έχουμε στο a1, μια κεφαλίδα και
από το a2 και κάτω, ονόματα μοναδικά (έστω 300)
*Θα πρέπει να προσέξουμε, τα ονόματα αυτά, πέρα από την μοναδικότητα,
να μην περιέχουν απαγορευμένους χαρακτήρες (< >/ \ ? : " *)

Αν τρέξουμε τον κώδικα, θα δημιουργηθούν τόσα αντίγραφα του Word αρχείου,
όσα και τα ονόματα της στήλης, με όνομα το κάθε ένα,
ένα όνομα από την στήλη, μέχρι να εξαντληθούν όλα.

Sub CopyWrdFile()
    Dim lrow As Long
    lrow = Sh1.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim path1 As String
    path1 = "Διαδρομή αρχείου Word\This is a test.dotx"
    
    Dim wApp
    Set wApp = CreateObject("Word.Application")
    wApp.DisplayAlerts = False
    
    Dim wDoc
    Set wDoc = wApp.Documents.Add(Template:=path1 , NewTemplate:=False, DocumentType:=0)
    
    Dim path2 As String, i As Long
    
    For i = 2 To lrow
        path2 = ThisWorkbook.Path & "\" & Range("a" & i).Value & ".docx"
        With wDoc
            wDoc.SaveAs Filename:=path2
        End With
    Next i
    
    wApp.DisplayAlerts = True
    MsgBox "Done!"
End Sub

Σημειώσεις (κόκκινο)
Όπου Sh1 = το κωδικό όνομα του φύλλου με τα ονόματα

Όπου 1 = αφορά την στήλη Α (μπορείτε να αλλάξετε, πχ με 3 για την στήλη C)

Διαδρομή αρχείου Word = Η Διαδρομή του αρχείου Word,
που ακολουθείται από το όνομα του σύν μια κατάληξη.

Όπου 2 = αφορά το κελί (γραμμή) που αρχίζουν τα ονόματα
Αν δεν υπάρχει κεφαλίδα, μπορείτε να αρχίσετε από το 1 (a1)
Αν έχετε κι άλλα δεδομένα, αντικαταστήστε ανάλογα
(πχ 5 αν τα ονόματα αρχίζουν από την 5η γραμμή)

ThisWorkbook.Path= Αν θέλετε τα αντίγραφα των αρχείων word,
να πάνε στον ίδιο φάκελο με το excel βιβλίο σας, μην κάνετε τίποτα.
Αν θέλετε να πάνε σε άλλο προορισμό, βάλτε στην θέση του, την διαδρομή που επιθυμείτε.

*Ο κώδικας δημιουργεί και αρχειοθετεί 300 αρχεία σε κάτι λιγότερο από 50 sec

[jimis]

σε ευχαριστώ πολύ για την απάντηση σου! δυστυχώς μου βγάζει σφάλμα

ποιο συγκεκριμένα έβαλα τον κώδικα ως εξής

Sub CopyWrdFile()
    Dim lrow As Long
    lrow = Öýëëï1 (εδώ σε εμένα γράφει Φύλλο1) .Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim path1 As String
    path1 = "C:\Users\Administrator\AppData\Roaming\Microsoft\???t?pa\F??µa.dotx
   (σε εμένα γράφει  C:\Users\Administrator\AppData\Roaming\Microsoft\Πρότυπα\Φόρμα.dotx)\This is a test.dotx"
    
    Dim wApp
    Set wApp = CreateObject("Word.Application")
    wApp.DisplayAlerts = False
    
    Dim wDoc
    Set wDoc = wApp.Documents.Add(Template:=path1, NewTemplate:=False, DocumentType:=0)
    
    Dim path2 As String, i As Long
    
    For i = 2 To lrow
        path2 = ThisWorkbook.Path & "\" & Range("a" & i).Value & ".docx"
        With wDoc
            wDoc.SaveAs Filename:=path2
        End With
    Next i
    
    wApp.DisplayAlerts = True
    MsgBox "Done!"
End Sub

και πάτησα F5 για να τρέξει ο κωδικας. μου βγάζει μήνυμα σφάλματος "Run-time error '13': Type Mismatch. μπορείς να καταλάβεις τι λάθος κάνω;

[Spirosgr]

Κατ' αρχάς ρίξε μια ματιά στην εικόνα.
Ό,τι είναι μέσα στην παρένθεση, αυτό πρέπει να μπεί στο lrow =.... (ώς φύλλο)
*είναι το κωδικό και όχι το φυσικό του όνομα (του φύλλου που έχει τα ονόματα)

Όσο για το path του word αρχείου, πρέπει να είναι:
*αν θέλεις να το βάλεις μαζί με τα πρόσθετα
C:\Users\Όνομα Χρήστη\AppData\Roaming\Microsoft\Addins\Φόρμα.dotx
Για Αγγλικό office
C:\Users\Όνομα Χρήστη\AppData\Roaming\Microsoft\Πρότυπα\Φόρμα.dotx
Για Ελληνικό office


Σημείωση
Επειδή ο AppData, είναι ένας «κρυφός» (σκιασμένος) φάκελος,
στους οποίους καλό είναι να μην πολυ μπαίνουμε αν δεν υπάρχει απόλυτη ανάγκη,
θα πρότεινα να βάλεις το word αρχείο (φόρμα), στα έγγραφά σου, σε ένα φάκελο που θα δημιουργήσεις για το σκοπό αυτό,
με όνομα της αρεσκείας σου (που φυσικά θα περιληφθεί στην διαδρομή)

[jimis]

Τα έκανα όλα όπως μου είπες και βγάζει πάλι σφάλμα. Συγκεκριμένα έφτιαξα έναν νέο φάκελο στα έγραφα με το όνομα Πρότυπα και έβαλα εκεί το αρχειο Φόρμα.dotx. τα office είναι ελληνικά 2007

[Spirosgr]

Δημήτρη,
στις σημειώσεις του πρώτου post, έγραψα:
«Διαδρομή αρχείου Word = Η Διαδρομή του αρχείου Word,
που ακολουθείται από το όνομα του σύν μια κατάληξη.»
και εννοεί διαδρομή συν αυτό:
\This is a test.dotx (σαν παράδειγμα τίτλου συν κατάληξης)
Στον κώδικα, έχεις ξεχάσει να το αφαιρέσεις.
Βγάλτο και θα δουλέψει...

Στο προηγούμενο post, σου έδωσα και ολόκληρο το string του path, ως:

C:\Users\Όνομα Χρήστη\AppData\Roaming\Microsoft\Πρότυπα\Φόρμα.dotx

για την περίπτωση του να το βάλεις στα πρότυπα...

[Spirosgr]

Συμπληρωματικά
Επειδή πολλές φορές, η εφαρμογή Word,
μπορεί να παραμένει «ανοιχτή» στον task manager,
με αποτέλεσμα να δημιουργούνται κάποια προβλήματα
πχ αν θέλουμε να διαγράψουμε ένα αρχείο, να βγαίνει μνμ ότι:
«Δεν μπορεί να γίνει διαγραφή, γιατί το αρχείο είναι ανοιχτό σε άλλη εφαρμογή...κλπ»
βάλε και αυτήν την γραμμή:

wApp.Quit

πριν το MsgBox και είναι καλυμμένο και αυτό.

[jimis]

σε ευχαριστώ πολύ!! πραγματικά δεν ξέρω πως κόλλησα και μου ξέφυγε αυτό! το δοκίμασα και λειτουργεί άψογα! απλά αν προσθέσω και άλλα ονόματα ποιο μετά θα τα κάνω μεμονωμένα με το χέρι (επειδή το δοκίμασα προσθέτοντας μια ακόμα ονομασία και μου έβγαλε σφάλμα). να ρωτήσω κάτι ακόμα με κίνδυνο να γίνω κουραστικός. Υπάρχει περίπτωση να μπορεί να αντιστοιχιστούν αυτόματα με υπερσύνδεσμο;

[Spirosgr]

Ως προς την προσθήκη ονομάτων δεν υπάρχει καμία περίπτωση, να έχει σφάλμα.
Κάτι δεν κάνεις καλά...
Για τον υπερσύνδεσμο, ναι γίνεται αλλά θα σου απαντήσω αύριο...

[jimis]

το ξανα έκανα (με επιπλεον ονομασίες) και όντως δεν έβγαλε σφάλμα δεν ξέρω τι λάθος είχα κάνει την πρώτη φόρα.

Σε ευχαριστώ πολύ για όλη την βοήθεια!! Καλό βράδυ!