excelden worde veri aktarma

Emir Hüseyin Çoban · 28 Ağustos 2010

merhaba arkadaşlar,

exceldeki verilerimi worde aktarmaya çalışıyorum, forumda arama yaptırdım ancak konu tarihleri eski olduğu için ekler silinmiş.
ekteki örnek dosyada da ayrıntılı olarak açıkladım,
tablodan 20 tane senet yazdıracağım, ancak yazdırmadan önce kontrol etmek için senet dökümlerini görmem gerekiyor
bunu önizleme ekranında yapınca kontrol o kadar güvenli olmuyor, senetleri word veya pdf e aktarıp ordan yazdırmam mümkün mü

yardım ve fikirlerinizi bekliyorum...

leumruk · 29 Ağustos 2010

Merhaba,
Aşağıdaki örneği inceleyiniz. Veri miktarınıza göre aktarma işlemi biraz sürebilir. Makro bitene kadar beklemelisiniz. Aşağıdaki örnek sayfalarınızı worde aktarır.
Kodu başka bir dosyada uygulayacağınız zaman Visual Basic bölümünden aşağıdaki referansı etkinleştirmeyi unutmayın.
Tools>References>Microsft Word 11.0 Object Library

Kod:

Sub Worde_Aktar()
If Sheets("giriş").OptionButton1 = True Then
Set sy = Sheets("senetyazı")
Set gr = Sheets("giriş")
Application.ScreenUpdating = False
Set WD = CreateObject("Word.Application")
WD.Visible = True
Set Dosya = WD.Documents.Add(DocumentType:=wdNewBlankDocument)
    With WD.Selection.PageSetup
        .TopMargin = WD.CentimetersToPoints(1)
        .BottomMargin = WD.CentimetersToPoints(1)
        .LeftMargin = WD.CentimetersToPoints(1)
        .RightMargin = WD.CentimetersToPoints(1)
    End With
Sheets("senetyazı").Select
ActiveWindow.View = xlPageBreakPreview
Syf_Sys = sy.HPageBreaks.Count + 1
Bsl = 2
grs = 52
Sut = 104
For x = 1 To Syf_Sys
If x = Syf_Sys Then
Son_Sat = sy.Cells.SpecialCells(xlCellTypeLastCell).Row
Else
Son_Sat = sy.HPageBreaks.Item(x).Location.Row - 1
End If
If gr.Cells(grs, "l") > 0 Then
sy.Range(sy.Cells(Bsl, 6), sy.Cells(Son_Sat, Sut)).Copy
WD.Selection.PasteSpecial Link:=False, DataType:=wdPasteOLEObject, Placement _
        :=wdInLine, DisplayAsIcon:=False
Application.CutCopyMode = False
If x < WorksheetFunction.CountA(gr.[l52:l71]) Then
WD.Selection.InsertBreak Type:=wdPageBreak
End If
End If
grs = grs + 1
Bsl = Son_Sat + 1
Next
ActiveWindow.View = xlNormalView
Sheets("giriş").Select
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation, "leumruk"
Else:
Application.ScreenUpdating = False
Sheets("senetlistesi").PrintOut Copies:=1
Application.ScreenUpdating = True
End If
End Sub

rahmi06 · 29 Ağustos 2010

Dosyanıza, form ve yazıyla fonksiyonunu ekledim. Kullanmak isterseniz ekten indirebilirsiniz.

Emir Hüseyin Çoban · 29 Ağustos 2010

teşekkürler sayın leumruk ve rahmi06
sorunsuz çalışıyor form u kullanmayacağım çünkü formlar konusunda bilgim yok,
tabloda herhangi bir değişiklik yapmam gerekirse müdahele edemem.

her zmn 20 tane senet yazdırmayacağım, "giriş" kitabına tutarlarını girdiğim senetleri word e aktarmamız mümkün mü
örneğin ilk 9 senete veri girdim sadece bunları aktara bilirmiyiz.

leumruk · 30 Ağustos 2010

huseyincoban' Alıntı:
her zmn 20 tane senet yazdırmayacağım, "giriş" kitabına tutarlarını girdiğim senetleri word e aktarmamız mümkün mü
örneğin ilk 9 senete veri girdim sadece bunları aktara bilirmiyiz.

Merhaba,
2 nolu mesajdaki kodları ve örnek dosyayı isteğiniz doğrultusunda düzenledim. Dosyayı yeniden deneyebilirsiniz.

Emir Hüseyin Çoban · 30 Ağustos 2010

tşkler sayın leumruk, sorunsuz çalışıyor.
ancak tabloda küçük bi ekleme daha yaptım,
sebebi ise 1 den fazla seneti word e aktarınca aralarından 1 sayfa boşluk bırakıyor, bu şekilde wordden yazdırmak uygun olmaz.
o yüzden tabloya birde "senet yazdır" butonu ekledim, TUTAR TL girilmiş olan senetleri yazdırmamız mümkün mü ?

leumruk · 30 Ağustos 2010

Merhaba,
Birer sayfa boşluk bırakma sıkıntısı ben de olmuyor. Kaç sayfa varsa wordde o kadar sayfa oluşuyor. Sanırım siz hazırladığım öreneği 2007'ye çevirip kullanıyorsunuz. Sıkıntı muhtemelen bundan kaynaklanıyor. 2003 ve 2007 arasında uyumsuzluklar çıkabilir.
Eklediğim kodu bir öncekinin yerine kopyalayın.

Kod:

Güncel kod 11. mesajda.

Emir Hüseyin Çoban · 30 Ağustos 2010

evet office 2007 kullanıyorum ondan olabilir ama yeni kodlar ile çok farklı bir durum oluştu.
konuya ekliyorum word belgesini ilginç bir şekilde attı senetleri word de

leumruk · 30 Ağustos 2010

Merhaba,
İlginçle kastettiğiniz nedir? Eklediğiniz dosyayı indirdim ve denedim. Herhangi bir sorun göremedim. Normal olmadığını söylediğiniz word dosyasını buraya ekler misiniz?

Emir Hüseyin Çoban · 30 Ağustos 2010

Kod:

Sub Worde_Aktar()
Set sy = Sheets("senetyazı")
Set gr = Sheets("giriş")
[COLOR="Red"]Syf_Sys = sy.HPageBreaks.Count + 1
grs = 52[/COLOR]
If Sheets("giriş").OptionButton1 = True Then
Application.ScreenUpdating = False
Set WD = CreateObject("Word.Application")
WD.Visible = True
Set Dosya = WD.Documents.Add(DocumentType:=wdNewBlankDocument)
    With WD.Selection.PageSetup
        .TopMargin = WD.CentimetersToPoints(1)
        .BottomMargin = WD.CentimetersToPoints(1)
        .LeftMargin = WD.CentimetersToPoints(1)
        .RightMargin = WD.CentimetersToPoints(1)
    End With
Sheets("senetyazı").Select
ActiveWindow.View = xlPageBreakPreview
[COLOR="Red"]Syf_Sys = sy.HPageBreaks.Count + 1
grs = 52
Bsl = 2
Sut = 104[/COLOR]
For x = 1 To Syf_Sys
If x = Syf_Sys Then
Son_Sat = sy.Cells.SpecialCells(xlCellTypeLastCell).Row
Else
Son_Sat = sy.HPageBreaks.Item(x).Location.Row - 1
End If
If gr.Cells(grs, "l") > 0 Then
sy.Range(sy.Cells(Bsl, 6), sy.Cells(Son_Sat, Sut)).Copy
WD.Selection.PasteSpecial Link:=False, DataType:=wdPasteOLEObject, Placement _
        :=wdInLine, DisplayAsIcon:=False
Application.CutCopyMode = False
If x < WorksheetFunction.CountA(gr.[l52:l71]) Then
WD.Selection.InsertBreak Type:=wdPageBreak
End If
End If
grs = grs + 1
Bsl = Son_Sat + 1
Next
ActiveWindow.View = xlNormalView
Sheets("giriş").Select
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation, "Microsoft Word"
ElseIf Sheets("giriş").OptionButton2 = True Then
Application.ScreenUpdating = False
Sheets("senetlistesi").PrintOut Copies:=1
Application.ScreenUpdating = True
ElseIf Sheets("giriş").OptionButton3 = True Then
For lm = 1 To Syf_Sys
Application.ScreenUpdating = False
If gr.Cells(grs, "l") > 0 Then
sy.PrintOut From:=lm, To:=lm, Copies:=1
End If
Application.ScreenUpdating = True
grs = grs + 1
Next
End If
End Sub

ilginçten kast ettiğim senetleri küçültüp hepsini bir sayfaya sığdırmasıydı, eklediğim resimde mevcut

sayın leumruk tşkler,
tam anlamıyla bitirdik tabloyu son düzeltmelerle beraber sorunsuz çalışıyor. office 2007 de birer sayfa boşluk bırakıyor konuya ekliyorum word belgesini.

office 2003 de tabloyu çalıştırmıyor.

dosya boyutu yüksek olduğu için rapid den yüklüyorum
http://rapidshare.com/files/416051101/Bel1_3008.rar

leumruk · 31 Ağustos 2010

Merhaba,
Boş sayfa eklemesinin sebebi exceldeki sayfalarınızın boy oranıyla word dosyasının sayfa boşluklarının uyuşmaması. Bundan dolayı excel tablosu sığmadığından sayfa alta taşıyor ve kodların için de de sayfa ekleme satırı olduğu için boş sayfadan sonra yeni sayfa ekliyor, aradaki boş kalıyordu. Mavi ile belirttiğim satırda wordün üst ve alt boşluk oranını düşürdüm sorun düzeldi. Bunun yerine excel sayfa boyutlarını bir miktar azaltarak da çözüme ulaşabilirsiniz.
Tek sayfaya yazma sorununa gelince Kırmızı satırları ekledim. Denem şansım olmadı. Muhtemelen sorunu düzeltmesi lazım. Eğer olmazsa bildirin yazıcıda deneyerek bir daha kontrol edeyim.

Kod:

Sub Worde_Aktar()
Set sy = Sheets("senetyazı")
Set gr = Sheets("giriş")
grs = 52
If Sheets("giriş").OptionButton1 = True Then
Application.ScreenUpdating = False
Set WD = CreateObject("Word.Application")
WD.Visible = True
Set Dosya = WD.Documents.Add(DocumentType:=wdNewBlankDocument)
    With WD.Selection.PageSetup
        .TopMargin = WD.CentimetersToPoints(0.5) 'Word üst boşluk ayarı
        .BottomMargin = WD.CentimetersToPoints(0.5) 'word alt boşluk ayarı
        .LeftMargin = WD.CentimetersToPoints(1)
        .RightMargin = WD.CentimetersToPoints(1)
    End With
Sheets("senetyazı").Select
ActiveWindow.View = xlPageBreakPreview
Syf_Sys = sy.HPageBreaks.Count + 1
Bsl = 2
Sut = 104
For x = 1 To Syf_Sys
If x = Syf_Sys Then
Son_Sat = sy.Cells.SpecialCells(xlCellTypeLastCell).Row
Else
Son_Sat = sy.HPageBreaks.Item(x).Location.Row - 1
End If
If gr.Cells(grs, "l") > 0 Then
sy.Range(sy.Cells(Bsl, 6), sy.Cells(Son_Sat, Sut)).Copy
WD.Selection.PasteSpecial Link:=False, DataType:=wdPasteOLEObject, Placement _
        :=wdInLine, DisplayAsIcon:=False
Application.CutCopyMode = False
If x < WorksheetFunction.CountA(gr.[l52:l71]) Then
WD.Selection.InsertBreak Type:=wdPageBreak
End If
End If
grs = grs + 1
Bsl = Son_Sat + 1
Next
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation, "Microsoft Word"
ElseIf Sheets("giriş").OptionButton2 = True Then
Application.ScreenUpdating = False
Sheets("senetlistesi").PrintOut Copies:=1
Application.ScreenUpdating = True
ElseIf Sheets("giriş").OptionButton3 = True Then
Sheets("senetyazı").Select
Application.ScreenUpdating = False
ActiveWindow.View = xlPageBreakPreview
Syf_Sys = sy.HPageBreaks.Count + 1
For lm = 1 To Syf_Sys
If gr.Cells(grs, "l") > 0 Then
sy.PrintOut From:=lm, To:=lm, Copies:=1
End If
grs = grs + 1
Next
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End If
Sheets("giriş").Select
End Sub

Emir Hüseyin Çoban · 31 Ağustos 2010

Kod:

Sub Worde_Aktar()
Set sy = Sheets("senetyazı")
Set gr = Sheets("giriş")
Syf_Sys = sy.HPageBreaks.Count + 1
grs = 52
If Sheets("giriş").OptionButton1 = True Then
Application.ScreenUpdating = False
Set WD = CreateObject("Word.Application")
WD.Visible = True
Set Dosya = WD.Documents.Add(DocumentType:=wdNewBlankDocument)
    With WD.Selection.PageSetup
        .TopMargin = WD.CentimetersToPoints(0.5)
        .BottomMargin = WD.CentimetersToPoints(0.5)
        .LeftMargin = WD.CentimetersToPoints(1)
        .RightMargin = WD.CentimetersToPoints(1)
    End With
Sheets("senetyazı").Select
ActiveWindow.View = xlPageBreakPreview
Syf_Sys = sy.HPageBreaks.Count + 1
grs = 52
Bsl = 2
Sut = 104
For x = 1 To Syf_Sys
If x = Syf_Sys Then
Son_Sat = sy.Cells.SpecialCells(xlCellTypeLastCell).Row
Else
Son_Sat = sy.HPageBreaks.Item(x).Location.Row - 1
End If
If gr.Cells(grs, "l") > 0 Then
sy.Range(sy.Cells(Bsl, 6), sy.Cells(Son_Sat, Sut)).Copy
WD.Selection.PasteSpecial Link:=False, DataType:=wdPasteOLEObject, Placement _
        :=wdInLine, DisplayAsIcon:=False
Application.CutCopyMode = False
If x < WorksheetFunction.CountA(gr.[l52:l71]) Then
WD.Selection.InsertBreak Type:=wdPageBreak
End If
End If
grs = grs + 1
Bsl = Son_Sat + 1
Next
ActiveWindow.View = xlNormalView
Sheets("giriş").Select
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation, "Microsoft Word"
ElseIf Sheets("giriş").OptionButton2 = True Then
Application.ScreenUpdating = False
Sheets("senetlistesi").PrintOut Copies:=1
Application.ScreenUpdating = True
ElseIf Sheets("giriş").OptionButton3 = True Then
For lm = 1 To Syf_Sys
Application.ScreenUpdating = False
If gr.Cells(grs, "l") > 0 Then
sy.PrintOut From:=lm, To:=lm, Copies:=1
End If
Application.ScreenUpdating = True
grs = grs + 1
Next
End If
End Sub

word e aktar kodları bu şekilde sorunsuz olarak çalışıyor,
ancak senet yazdır seçeneğinde sadece ilk 2 seneti yazdırıyor, diğer senetler dolu olduğu halde yazdırmıyor.

leumruk · 1 Eylül 2010

Merhaba,
Bazı satırların yerleştirmesine dikkat etmemişim. 11. mesajdaki kodu düzenledim. Yeniden deneyebilirsiniz.

Emir Hüseyin Çoban · 1 Eylül 2010

tşkler yardımlarınız için, sorunsuz olarak çalışıyor.

assenucler · 8 Haziran 2012

Sayın Lemruk ve Hüseyin Çoban;

Günaydınlar. Bu güzel dosyayı yeni gördüm.

Emek ve katkılarınız için teşekkürler.

Sevgi ve saygılar.

excelden worde veri aktarma

Emir Hüseyin Çoban

Destek Ekibi

Ekli dosyalar

leumruk

Uzman

Ekli dosyalar

rahmi06

Ekli dosyalar

Emir Hüseyin Çoban

Destek Ekibi

leumruk

Uzman

Emir Hüseyin Çoban

Destek Ekibi

Ekli dosyalar

leumruk

Uzman

Emir Hüseyin Çoban

Destek Ekibi

Ekli dosyalar

leumruk

Uzman

Emir Hüseyin Çoban

Destek Ekibi

leumruk

Uzman

Emir Hüseyin Çoban

Destek Ekibi

leumruk

Uzman

Emir Hüseyin Çoban

Destek Ekibi

assenucler