Καλησπέρα και Χρόνια πολλά!
Ο κώδικας πιο κάτω, κάνει το εξής:
Έστω ένα αρχείο 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