Word sayfalarını yatay yapma

[sberktas]

Aşağıdaki kod malumunuz olduğu gibi excel den word belgesine resim atan bir kod ancak sayfalar hep dikey oluyor benim amacım açılan word sayfalarının yatay olmasını sağlamak. Bunun için bu kodun neresinde değişiklik yapmam lazım. Şimdiden yardımlarınız ve desteklerinin için teşekkür ederim. (Bu siteden sayın "l e u m r u k" hocamızın bir çalışmasıdır.)



Sub Düğme18_Tıklat()
Set s1 = Sheets("SAYFALAR")
Set s2 = Sheets("YatirimButcesi")
yol = ThisWorkbook.Path & "\Tablolar\"
Application.ScreenUpdating = False
Set wd = CreateObject("Word.Application")
Set wddoc = wd.Documents.Add(DocumentType:=0)
wd.Visible = False
For x = 1 To s1.Cells(Rows.Count, 1).End(1).Row
If s1.Cells(x, 1) = "1" Then
s2.[z9] = s1.Cells(x, 1)
s2.Range("b38").CopyPicture
wd.ActiveDocument.Bookmarks("\page").Range.Delete
wd.Selection.Paste
wddoc.SaveAs yol & s1.[b1].Text & "-" & Format(Now, "dd.mm.yyyy hh_mm_ss") & ".doc"
End If
Next
wd.Visible = True
wddoc.Application.Quit
Application.CutCopyMode = False
Application.ScreenUpdating = True
'MsgBox "İşlem tamamlandı.", vbInformation, "l e u m r u k"
End Sub

 

[leumruk]

Merhaba,
Şu kodu makronuza ekleyin.

Sub Düğme18_Tıklat()
Set s1 = Sheets("SAYFALAR")
Set s2 = Sheets("YatirimButcesi")
yol = ThisWorkbook.Path & "\Tablolar\"
Application.ScreenUpdating = False
Set wd = CreateObject("Word.Application")
Set wddoc = wd.Documents.Add(DocumentType:=0)
wd.Visible = False
For x = 1 To s1.Cells(Rows.Count, 1).End(1).Row
If s1.Cells(x, 1) = "1" Then
s2.[z9] = s1.Cells(x, 1)
s2.Range("b38").CopyPicture
wd.ActiveDocument.Bookmarks("\page").Range.Delete
wd.Selection.Paste
wddoc.SaveAs yol & s1.[b1].Text & "-" & Format(Now, "dd.mm.yyyy hh_mm_ss") & ".doc"
End If
Next
[COLOR="DarkRed"][B]If wd.Selection.PageSetup.Orientation = 0 Then
        wd.Selection.PageSetup.Orientation = 1
End If[/B][/COLOR]
wd.Visible = True
wddoc.Application.Quit
Application.CutCopyMode = False
Application.ScreenUpdating = True
'MsgBox "İşlem tamamlandı.", vbInformation, "l e u m r u k"
End Sub

 

[sberktas]

sayın hocam öncelikle kusur bende daha yeni dönüş yapabildim. Vermiş olduğunuz kod çok ama çok işime yaradı. Öncelikle bunun için çok teşekkür ederim. Lakin şimdi farklı bir soru veya sorun ile karşılaşmaktayım. Aktarım işlemini gerçekleştiriyorum lakin aktardığımız word sayfasının kenar boşluklarını ayarlaya bilme şansımız var mı? şöyle ki tablo aktarıldığında belirli bir kısmı altta kalıyor ve okunmuyor bu yüzden kenar boşlukları daraltmam lazım.
İlginiz ve alakanız için çokkkkk teşekkür ederim.

 

[Saban Sertkaya]

Dönüş için biraz geç kalmış gibisiniz sanki..

 

[Saban Sertkaya]

Aşağıdaki şekilde bir deneyiniz.

Sub Düğme18_Tıklat()
Set s1 = Sheets("SAYFALAR")
Set s2 = Sheets("YatirimButcesi")
yol = ThisWorkbook.Path & "\Tablolar\"
Application.ScreenUpdating = False
Set wd = CreateObject("Word.Application")
Set wddoc = wd.Documents.Add(DocumentType:=0)
wd.Visible = False
For x = 1 To s1.Cells(Rows.Count, 1).End(1).Row
If s1.Cells(x, 1) = "1" Then
s2.[z9] = s1.Cells(x, 1)
s2.Range("b38").CopyPicture
wd.ActiveDocument.Bookmarks("\page").Range.Delete
wd.Selection.Paste
wddoc.SaveAs yol & s1.[b1].Text & "-" & Format(Now, "dd.mm.yyyy hh_mm_ss") & ".doc"
End If
Next
If wd.Selection.PageSetup.Orientation = 0 Then
        wd.Selection.PageSetup.Orientation = 1
End If
[B][COLOR="Red"]
'20 rakamını değiştirerek uygun aralığı bulunuz.
wd.Selection.PageSetup.TopMargin = 20 'Üst Marjin
wd.Selection.PageSetup.BottomMargin = 20 'Alt Marjin
wd.Selection.PageSetup.LeftMargin = 20 'Sol Marjin
wd.Selection.PageSetup.RightMargin = 20 'Sağ Marjin
[/COLOR][/B]
wd.Visible = True
wddoc.Application.Quit
Application.CutCopyMode = False
Application.ScreenUpdating = True
'MsgBox "İşlem tamamlandı.", vbInformation, "l e u m r u k"
End Sub