4 word kitapçığını ardı ardına 100 takım bastırma?

O

ogameci

Katılım
11 Ekim 2011
Mesajlar
61
Excel Vers. ve Dili
2013 TR
Altın Üyelik Bitiş Tarihi
27.05.2019
Merhaba,
A, B, C, D isimli dört adet word dosyası var. Bunları yazıcıda A,B,C,D,A,B,C,D... şeklinde 100 takım (bir takımda A,B,C,D word dosyası var) print edebimenin bir yolu var mıdır?

Normalde yazıcıya 100 tane A bas, 100 tane B bas... emri gönderip sonra elle A,B,C,D sıralaması yapıyoruz. Vakit kaybı oluyor.

Sınav kağıtları basımı içindir. Yazıcı otomatik zımbalama yaptığından kitapçıkları tek word belgesine çevirmek işe yaramıyor.
 
Son düzenleme:
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Yaptığım araştırmalar sonucunda aşağıdaki makroyu oluşturdum. Bu kodlar C:/SORU klasörü altındaki belirtilen dosyaları yazdırma işlemi yapıyor. Dikkat etmeniz gereken hususlar dosya yolunun ve dosya isimlerinin doğru bir şekilde yazılmasıdır. Buna uzantılar da dahil. Kodda docx olarak belirttim ancak sizin uzantınız doc ise ona göre düzeltin. Kodları bir modüle kopyalayıp çalıştırın:

Kod: 
Sub yazdır()
   Dim sMyDir As String
   Dim sDocName As String
   sMyDir = "C:\SORU\"
   For i = 1 To 100
      Application.PrintOut FileName:=sMyDir & "A.docx"
      Application.PrintOut FileName:=sMyDir & "B.docx"
      Application.PrintOut FileName:=sMyDir & "C.docx"
      Application.PrintOut FileName:=sMyDir & "D.docx"
   Next
End Sub
 
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
Alternatif deneyiniz.

Ana ekranda, yazdırılacak word dosyalarının seçimi. Kaç takım yazdıracağınızı, her bir word yazımı arasında kaç saniye bekleneceğini ve her bir takım arasına ayırıcı bir word sayfası seçimi yapabilir siniz.

http://s2.dosya.tc/server/de3s02/Word_Takim_Yazdir.zip.html

Edit:

objDoc.Close satırlarını objDoc.Close False olarak düzeltiniz.
Kod: 
'Asri Akdeniz - asriakdeniz@gmail.com 23.05.2016

Dim beklemesuresi, kactakim, ensonsatir, ensonsutun As Long
Dim FSO As Object
Dim dosya1, dosya1adi, dosya2, dosya2adi, dosya3, dosya3adi, dosya4 As String

Sub ensonsatir_ensonsutun()
  If WorksheetFunction.CountA(Cells) > 0 Then
     ensonsatir = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
     ensonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
  Else
     ensonsatir = Rows.Count
     ensonsutun = Columns.Count
  End If
  
End Sub

Sub menu()
 Sheets("Menu").Select
 kactakim = Cells(11, 1).Value
 beklemesuresi = Cells(14, 1).Value
 Call word_yazdir
 MsgBox ("Yazdırma işlemi tamanlandı.")
 
End Sub

Sub dosyayukle1()
  Set myFile = Application.FileDialog(msoFileDialogOpen)
  With myFile
    .Title = "Dosya Seçiniz"
    .AllowMultiSelect = False
    If .Show <> -1 Then
       dosya1 = ""
       dosya1adi = ""
       Cells(2, 4).Value = ""
       Exit Sub
    End If
    dosya1 = .SelectedItems(1)
    dosya1adi = Mid(.SelectedItems(1), InStrRev(.SelectedItems(1), "\") + 1, Len(.SelectedItems(1)))
    Cells(2, 4).Value = dosya1
 End With
End Sub
    
Sub dosyayukle2()
  Set myFile = Application.FileDialog(msoFileDialogOpen)
  With myFile
    .Title = "Dosya Seçiniz"
    .AllowMultiSelect = False
    If .Show <> -1 Then
       dosya2 = ""
       dosya2adi = ""
       Cells(3, 4).Value = ""
       Exit Sub
    End If
    dosya2 = .SelectedItems(1)
    dosya2adi = Mid(.SelectedItems(1), InStrRev(.SelectedItems(1), "\") + 1, Len(.SelectedItems(1)))
    Cells(3, 4).Value = dosya2
 End With
End Sub
        
Sub dosyayukle3()
  Set myFile = Application.FileDialog(msoFileDialogOpen)
  With myFile
    .Title = "Dosya Seçiniz"
    .AllowMultiSelect = False
    If .Show <> -1 Then
       dosya3 = ""
       dosya3adi = ""
       Cells(4, 4).Value = ""
       Exit Sub
    End If
    dosya3 = .SelectedItems(1)
    dosya3adi = Mid(.SelectedItems(1), InStrRev(.SelectedItems(1), "\") + 1, Len(.SelectedItems(1)))
    Cells(4, 4).Value = dosya3
 End With
End Sub

Sub dosyayukle4()
  Set myFile = Application.FileDialog(msoFileDialogOpen)
  With myFile
    .Title = "Dosya Seçiniz"
    .AllowMultiSelect = False
    If .Show <> -1 Then
       dosya4 = ""
       dosya4adi = ""
       Cells(8, 4).Value = ""
       Exit Sub
    End If
    dosya4 = .SelectedItems(1)
    dosya4adi = Mid(.SelectedItems(1), InStrRev(.SelectedItems(1), "\") + 1, Len(.SelectedItems(1)))
    Cells(8, 4).Value = dosya4
 End With
End Sub


Sub word_yazdir()
  Dim objWord
  Set objWord = CreateObject("Word.Application")
  objWord.Visible = False
  Dim objDoc
  For j = 1 To kactakim
    For i = 2 To 5
      Set objDoc = objWord.Documents.Open(Cells(i, 4).Value)
      objDoc.PrintOut
      'Yazıcıya gönderdikten sonra 5 sn bekle
      saniye = 0.00001157407407
      Application.Wait (Now + beklemesuresi * saniye)
      objDoc.Close False
    Next i
    'Ayırıcı sayfayı yazdır
    Set objDoc = objWord.Documents.Open(Cells(8, 4).Value)
    objDoc.PrintOut
    objDoc.Close False
  Next j
  objWord.Quit
End Sub
 
Son düzenleme:
O

ogameci

Katılım
11 Ekim 2011
Mesajlar
61
Excel Vers. ve Dili
2013 TR
Altın Üyelik Bitiş Tarihi
27.05.2019
YUSUF44' Alıntı:
Yaptığım araştırmalar sonucunda aşağıdaki makroyu oluşturdum. Bu kodlar C:/SORU klasörü altındaki belirtilen dosyaları yazdırma işlemi yapıyor. Dikkat etmeniz gereken hususlar dosya yolunun ve dosya isimlerinin doğru bir şekilde yazılmasıdır. Buna uzantılar da dahil. Kodda docx olarak belirttim ancak sizin uzantınız doc ise ona göre düzeltin. Kodları bir modüle kopyalayıp çalıştırın:

Kod: 
Sub yazdır()
   Dim sMyDir As String
   Dim sDocName As String
   sMyDir = "C:\SORU\"
   For i = 1 To 100
      Application.PrintOut FileName:=sMyDir & "A.docx"
      Application.PrintOut FileName:=sMyDir & "B.docx"
      Application.PrintOut FileName:=sMyDir & "C.docx"
      Application.PrintOut FileName:=sMyDir & "D.docx"
   Next
End Sub
Genişletmek için tıkla ...
asri' Alıntı:
Alternatif deneyiniz.

Ana ekranda, yazdırılacak word dosyalarının seçimi. Kaç takım yazdıracağınızı, her bir word yazımı arasında kaç saniye bekleneceğini ve her bir takım arasına ayırıcı bir word sayfası seçimi yapabilir siniz.

http://s2.dosya.tc/server/de3s02/Word_Takim_Yazdir.zip.html

Edit:

objDoc.Close satırlarını objDoc.Close False olarak düzeltiniz.
Kod: 
'Asri Akdeniz - asriakdeniz@gmail.com 23.05.2016

Dim beklemesuresi, kactakim, ensonsatir, ensonsutun As Long
Dim FSO As Object
Dim dosya1, dosya1adi, dosya2, dosya2adi, dosya3, dosya3adi, dosya4 As String

Sub ensonsatir_ensonsutun()
  If WorksheetFunction.CountA(Cells) > 0 Then
     ensonsatir = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
     ensonsutun = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
  Else
     ensonsatir = Rows.Count
     ensonsutun = Columns.Count
  End If
  
End Sub

Sub menu()
 Sheets("Menu").Select
 kactakim = Cells(11, 1).Value
 beklemesuresi = Cells(14, 1).Value
 Call word_yazdir
 MsgBox ("Yazdırma işlemi tamanlandı.")
 
End Sub

Sub dosyayukle1()
  Set myFile = Application.FileDialog(msoFileDialogOpen)
  With myFile
    .Title = "Dosya Seçiniz"
    .AllowMultiSelect = False
    If .Show <> -1 Then
       dosya1 = ""
       dosya1adi = ""
       Cells(2, 4).Value = ""
       Exit Sub
    End If
    dosya1 = .SelectedItems(1)
    dosya1adi = Mid(.SelectedItems(1), InStrRev(.SelectedItems(1), "\") + 1, Len(.SelectedItems(1)))
    Cells(2, 4).Value = dosya1
 End With
End Sub
    
Sub dosyayukle2()
  Set myFile = Application.FileDialog(msoFileDialogOpen)
  With myFile
    .Title = "Dosya Seçiniz"
    .AllowMultiSelect = False
    If .Show <> -1 Then
       dosya2 = ""
       dosya2adi = ""
       Cells(3, 4).Value = ""
       Exit Sub
    End If
    dosya2 = .SelectedItems(1)
    dosya2adi = Mid(.SelectedItems(1), InStrRev(.SelectedItems(1), "\") + 1, Len(.SelectedItems(1)))
    Cells(3, 4).Value = dosya2
 End With
End Sub
        
Sub dosyayukle3()
  Set myFile = Application.FileDialog(msoFileDialogOpen)
  With myFile
    .Title = "Dosya Seçiniz"
    .AllowMultiSelect = False
    If .Show <> -1 Then
       dosya3 = ""
       dosya3adi = ""
       Cells(4, 4).Value = ""
       Exit Sub
    End If
    dosya3 = .SelectedItems(1)
    dosya3adi = Mid(.SelectedItems(1), InStrRev(.SelectedItems(1), "\") + 1, Len(.SelectedItems(1)))
    Cells(4, 4).Value = dosya3
 End With
End Sub

Sub dosyayukle4()
  Set myFile = Application.FileDialog(msoFileDialogOpen)
  With myFile
    .Title = "Dosya Seçiniz"
    .AllowMultiSelect = False
    If .Show <> -1 Then
       dosya4 = ""
       dosya4adi = ""
       Cells(8, 4).Value = ""
       Exit Sub
    End If
    dosya4 = .SelectedItems(1)
    dosya4adi = Mid(.SelectedItems(1), InStrRev(.SelectedItems(1), "\") + 1, Len(.SelectedItems(1)))
    Cells(8, 4).Value = dosya4
 End With
End Sub


Sub word_yazdir()
  Dim objWord
  Set objWord = CreateObject("Word.Application")
  objWord.Visible = False
  Dim objDoc
  For j = 1 To kactakim
    For i = 2 To 5
      Set objDoc = objWord.Documents.Open(Cells(i, 4).Value)
      objDoc.PrintOut
      'Yazıcıya gönderdikten sonra 5 sn bekle
      saniye = 0.00001157407407
      Application.Wait (Now + beklemesuresi * saniye)
      objDoc.Close False
    Next i
    'Ayırıcı sayfayı yazdır
    Set objDoc = objWord.Documents.Open(Cells(8, 4).Value)
    objDoc.PrintOut
    objDoc.Close False
  Next j
  objWord.Quit
End Sub
Genişletmek için tıkla ...
Çok çok teşekkür ederim. Sağolun

@asri; Ayırıcı sayfa word belgesi yazılmaması gerekiyor. Aşağıdaki satırları silmem yeterli olacak sanırım:
'Ayırıcı sayfayı yazdır
Set objDoc = objWord.Documents.Open(Cells(8, 4).Value)
objDoc.PrintOut
objDoc.Close False
Genişletmek için tıkla ...
 
Son düzenleme:
Asri

Asri

Katılım
24 Nisan 2005
Mesajlar
3,671
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Altın Üyelik Bitiş Tarihi
25/05/2022
H

Harun_Y

Altın Üye
Katılım
11 Şubat 2016
Mesajlar
44
Excel Vers. ve Dili
Excel -2007-2010-2013-2016
Altın Üyelik Bitiş Tarihi
10/05/2027
bu kadar uğraşmanıza gerek yok print conductor programını netten indirin word excel pdf ne tür isterseniz kaç takım hangi sıra isterseniz basın.
 
O

ogameci

Katılım
11 Ekim 2011
Mesajlar
61
Excel Vers. ve Dili
2013 TR
Altın Üyelik Bitiş Tarihi
27.05.2019
Harun_Y' Alıntı:
bu kadar uğraşmanıza gerek yok print conductor programını netten indirin word excel pdf ne tür isterseniz kaç takım hangi sıra isterseniz basın.
Genişletmek için tıkla ...

Aaa böyle bir program varmış. Ayarında dosyaları sırala var. Sanırım takım takım basıyor.

@asri yazdığını printer seçme seçeneği ekleyerek düzenlemeye çalıştım. Onu paylaşayım:
http://s4.dosya.tc/server2/1llac6/Word_Takim_Yazdir.rar.html
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst