Word Dosyalarını Makro İle Toplu Yazdırma

[sametozyavuz]

Bir ana klasörün içerisinde birden çok alt klasörler var. Bu klasörlerin içerisinde *.docx ve *.doc uzantılı birçok word dosyası var. ben bunların hepsini tek makro ile yazdırabilir miyim?

 

[sametozyavuz]

Değerli arkadaşlar konu hala güncel.
500 sayfalık bir çalışma hem uzun sürmesin hemde hata olmasın istiyorum.
olmaz diyenler de olmaz yazsın.

 

[YUSUF44]

Sorununuzu çözer mi bilmem ancak, ana klasörde doc ve docx uzantılı belgeleri arattıktan sonra hepsi aynı ekranda listelenir, yani farklı klasördekiler de aynı ekranda listelenir. Bu çıkanları kopyalayıp başka bir klasöre yapıştırarak tüm dosyaların aynı yerde olmasını sağlayabilirsiniz. Daha sonra da çözümünüzü tek klasördeki dosyalar için arayabilirsiniz. Örneğin az önce aynı klasördeki iki belgeyi aynı anda seçip sağ tıklayarak yazdır dediğimde ikisini de yazdırdı.

 

[sametozyavuz]

Sorununuzu çözer mi bilmem ancak, ana klasörde doc ve docx uzantılı belgeleri arattıktan sonra hepsi aynı ekranda listelenir, yani farklı klasördekiler de aynı ekranda listelenir. Bu çıkanları kopyalayıp başka bir klasöre yapıştırarak tüm dosyaların aynı yerde olmasını sağlayabilirsiniz. Daha sonra da çözümünüzü tek klasördeki dosyalar için arayabilirsiniz. Örneğin az önce aynı klasördeki iki belgeyi aynı anda seçip sağ tıklayarak yazdır dediğimde ikisini de yazdırdı.

aslında dediğiniz çok güzel bir yöntem.
bende buna uygun bir kodda var.

Sub Oval1_Tıklat()
Set WD = CreateObject("word.Application")
WD.Visible = True
yol = ThisWorkbook.Path
Dosya = Dir(yol & "\*doc*")
Do While Dosya <> ""
WD.Application.Documents.Open yol & "\" & Dosya
Application.Wait (Now + TimeValue("0:00:01"))
WD.ActiveDocument.PrintOut
Dosya = Dir
Loop
Application.Wait (Now + TimeValue("0:00:01"))
WD.Application.Quit
MsgBox "İşlem tamamlanmıştır."
End Sub

fakat sorun bu durumda belgelerin sıralaması değişecek ve sayfalar karışık çıkacak.bu kod tüm belgeleri ada göre sırası ile açıyor ve sayfalar karışmıyor.

yarına kadar daha iyisini bulamazsam, son çare olarak kodun olduğu excel kitabını her klasöre kopyalayıp yazdırmak olarak çözeceğim.

 

[leumruk]

merhaba,
verdiğim linkte alt klasörleri ve içindeki dosyaları listelemeye yarayan kodlar var. bu kodlara print.out kodunu ekleyerek çözüm bulabilirsiniz.

 

[sametozyavuz]

Mustafa bey ilginiz için çok teşekkür ederim.
zaten bendeki kod da sizin arşivinizden.
ama link yok. yeniden kontrol edermisiniz.

 

[leumruk]

Merhaba,
Aşağıdaki kodu bir excel dosyasına ekleyin ve makroyu çalıştırdıktan sonra word dosyalarının bulunduğu klasörü seçin.

Sub Word_Yazdir()
Set ds = CreateObject("Scripting.FileSystemObject")
Set shl = CreateObject("Shell.Application")
Set yol = shl.BrowseForFolder(0, "Lütfen bir klasör seçiniz!", 0)
If yol Is Nothing Then Exit Sub
yol = yol.self.Path
Columns(1).Clear
Application.ScreenUpdating = False
Do
Tekrar:
If ds.GetFolder(yol).subfolders.Count > 0 Then
    For Each kls In ds.GetFolder(yol).subfolders
        klslst = klslst & "{" & kls
    Next
End If
x = x + 1
deg = Split(klslst, "{")
yol = deg(x)
dosya = Dir$(yol & "\*.doc*")

Do While dosya <> ""
Say = Say + 1
Cells(Say, 1) = yol & "\" & dosya
dosya = Dir$()
Loop
If x = 1 And ds.GetFolder(yol).subfolders.Count > 0 Then GoTo Tekrar
Loop While UBound(deg) <> x

If Cells(1, 1) <> "" Then
Set wd = CreateObject("word.Application")
wd.Visible = True
For wpr = 1 To Cells(Rows.Count, 1).End(3).Row
wd.Application.Documents.Open Cells(wpr, 1).Text
wd.ActiveDocument.PrintOut
wd.ActiveDocument.Close False
Next
wd.Application.Quit
Columns(1).Delete shift:=xlUp
End If
'Kodlayan: l e u m r u k - mustafa altun
End Sub

 

[sametozyavuz]

Sn Mustafa bey Word belgelerinin olduğu Klasörü Seçtikten Sonra Run Time Eror Hatası alıyorum.
kodlar sizde çalışıyor mu?

 

[leumruk]

Deneyip yolladım. Ben de çalıştı. Hangi satırda hata verdi?

 

[sametozyavuz]

sn mustafa bey kodu bu gün denedim çalıştı. o zaman neden hata verdiğini anlayamadım.
ilginize emeğinize çok teşekkür ederim.
geç cevap için özür dilerim müsait olamadım.

 

[KuTuKa]

Merhaba
bende aşağıdaki hatayı verdi
Run -time eror '9'
subscript out of range

 

[1903emre34@gmail.com]

Merhaba,

Aynı hatayı verdi, kodlarda nasıl değişiklik yapabiliriz?

 

[sametozyavuz]

kodları değiştirmeye gerek yok.
kodun yazıldığı excel kitabını yazdırmak istediğiniz klasörden başka bir yere koyun.

https://1drv.ms/x/s!AnHSS9_BAQTpmUrRqvEYRo5pYsdV