Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > Diğer Yazılımlar > Windows-Word-PowerPoint....
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Windows-Word-PowerPoint.... Excel haricindeki Ofis programları ile ilgili konular.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 22-05-2016, 20:19   #1
ogameci
Altın Üye
 
Giriş: 11/10/2011
Şehir: İstanbul'a ne yakın ne çok uzak
Mesaj: 46
Excel Vers. ve Dili:
Yeni versiyona hayır demem :)
Varsayılan 4 word kitapçığını ardı ardına 100 takım bastırma?

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.

Bu mesaj en son " 02-10-2017 " tarihinde saat 23:44 itibariyle ogameci tarafından düzenlenmiştir....
ogameci Çevrimdışı   Alıntı Yaparak Cevapla
Eski 23-05-2016, 09:10   #2
YUSUF44
Destek Ekibi
 
YUSUF44 kullanıcısının avatarı
 
Giriş: 04/01/2006
Şehir: Manisa, Kula
Mesaj: 6,029
Excel Vers. ve Dili:
İş : Ofis 2016 - Türkçe Ev: Yok maalesef.
Varsayılan

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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
YUSUF44 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 23-05-2016, 10:37   #3
asri
Altın Üye
 
Giriş: 24/04/2005
Şehir: Istanbul
Mesaj: 2,374
Excel Vers. ve Dili:
Office 2016 TR 64 Bit
Varsayılan

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/Wor...azdir.zip.html

Edit:

objDoc.Close satırlarını objDoc.Close False olarak düzeltiniz.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
'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
__________________
www.asriakdeniz.com

Bu mesaj en son " 23-05-2016 " tarihinde saat 11:31 itibariyle asri tarafından düzenlenmiştir....
asri Çevrimdışı   Alıntı Yaparak Cevapla
Eski 28-07-2016, 01:22   #4
ogameci
Altın Üye
 
Giriş: 11/10/2011
Şehir: İstanbul'a ne yakın ne çok uzak
Mesaj: 46
Excel Vers. ve Dili:
Yeni versiyona hayır demem :)
Thumbs up

Alıntı:
YUSUF44 tarafından gönderildi Mesajı Görüntüle
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: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
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
Alıntı:
asri tarafından gönderildi Mesajı Görüntüle
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/Wor...azdir.zip.html

Edit:

objDoc.Close satırlarını objDoc.Close False olarak düzeltiniz.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
'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
Ç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:
Alıntı:
'Ayırıcı sayfayı yazdır
Set objDoc = objWord.Documents.Open(Cells(8, 4).Value)
objDoc.PrintOut
objDoc.Close False

Bu mesaj en son " 28-07-2016 " tarihinde saat 02:01 itibariyle ogameci tarafından düzenlenmiştir....
ogameci Çevrimdışı   Alıntı Yaparak Cevapla
Eski 28-07-2016, 08:25   #5
asri
Altın Üye
 
Giriş: 24/04/2005
Şehir: Istanbul
Mesaj: 2,374
Excel Vers. ve Dili:
Office 2016 TR 64 Bit
Varsayılan

Alıntı:
ogameci tarafından gönderildi Mesajı Görüntüle
Ç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:
Evet yeterli olur.
__________________
www.asriakdeniz.com
asri Çevrimdışı   Alıntı Yaparak Cevapla
Eski 28-07-2016, 23:11   #6
ogameci
Altın Üye
 
Giriş: 11/10/2011
Şehir: İstanbul'a ne yakın ne çok uzak
Mesaj: 46
Excel Vers. ve Dili:
Yeni versiyona hayır demem :)
Varsayılan

Alıntı:
asri tarafından gönderildi Mesajı Görüntüle
Evet yeterli olur.
Teşekkürler
ogameci Çevrimdışı   Alıntı Yaparak Cevapla
Eski 29-07-2016, 21:21   #7
Harun_Y
Altın Üye
 
Giriş: 11/02/2016
Şehir: ankara
Mesaj: 18
Excel Vers. ve Dili:
Excel 2010-2013
Varsayılan

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.
Harun_Y Çevrimdışı   Alıntı Yaparak Cevapla
Eski 29-07-2016, 21:39   #8
ogameci
Altın Üye
 
Giriş: 11/10/2011
Şehir: İstanbul'a ne yakın ne çok uzak
Mesaj: 46
Excel Vers. ve Dili:
Yeni versiyona hayır demem :)
Varsayılan

Alıntı:
Harun_Y tarafından gönderildi Mesajı Görüntüle
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.

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/Wo...azdir.rar.html
ogameci Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 20:24


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım - Tarot Falı - invest in turkey - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Özel Eğitim- Site Yönetimi- Led Aydınlatma- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Boru Profil- Gebze Emlak- Beylikdüzü Temizlik- İstanbul Burun Estetiği- Bakır Sülfat- Rampa- Rotary- Çorlu İnternet Sitesi- youngblood- Çorlu Palet- Çerkezköy Palet- Çorlu Prefabrik- Çorlu Sürücü Kursu- Çorlu Sandviç Panel- Şişli Avukat- Korona Test Kalemi- Çorlu Vinç- Çorlu Pimapen Tamiri- Çorlu Çelik Konstruksiyon-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden