Worde Aktar Makrosuna düzenleme Talebi

[sirkülasyon]

Sub ExceldenWordeaktar()
' Microsoft Word Object Library kitaplığını aktif hale getirin
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
' Excelde bir aralık seçin
If Not TypeName(Selection) = "Range" Then
    MsgBox "Lütfen excel sayfasından aralığınızı seçiniz", vbExclamation, _
        "Hiçbir aralık seçilmedi"
Else
    ' Word belgeside açık olmalıdır
    Set WDApp = GetObject(, "Word.Application")
    ' Referans aktif doküman alınacak
    Set WDDoc = WDApp.ActiveDocument
    ' Aralık kopyalanacak
    Selection.Copy
    ' Aralık yapıştırılacak
    WDApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _
        Placement:=wdInLine, DisplayAsIcon:=False
    ' Temizlenecek
    Set WDDoc = Nothing
    Set WDApp = Nothing
End If
End Sub

Yukarıda yer alan Kodun linki aşağıda yer almaktadır.
http://www.excel.web.tr/f42/excel-verilerini-worde-aktarma-t20863.html
Ali Uzmanıma ait kod. Kod çalışıyor.
1- kopyalama yaptıktan sonra Excel deki seçili yer işaretli kalıyor. o işareti kaldırabilecek bir kod
2- Tekrar aktarma yapınca eskiyi silmiyor. Eskiyi silecek bir kod
3- Worde aktarma yaptıktan sonra Word de düzenlemeye izin vermiyor. Düzenleme yapmama izin verecek bir kod

eklemenizi uzmanlarımdan rica ediyorum.

Teşekkür Eder Saygılarımı sunarım

 

[alicimri]

İlk iki isteğinize göre kodları değiştirdim ama üçüncü istediğinizi anlamadım.

Sub ExceldenWordeaktar()
' Microsoft Word Object Library kitaplığını aktif hale getirin
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
' Excelde bir aralık seçin
If Not TypeName(Selection) = "Range" Then
    MsgBox "Lütfen excel sayfasından aralığınızı seçiniz", vbExclamation, _
        "Hiçbir aralık seçilmedi"
Else
    ' Word belgeside açık olmalıdır
    Set WDApp = GetObject(, "Word.Application")
    ' Referans aktif doküman alınacak
    Set WDDoc = WDApp.ActiveDocument
    [COLOR="Blue"]  ' Eski tablo siliniyor
    If WDDoc.Tables.Count <> 0 Then
   WDDoc.Tables(1).Delete
   End If[/COLOR]
   ' Aralık kopyalanacak
    Selection.Copy
    ' Aralık yapıştırılacak
    WDApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _
        Placement:=wdInLine, DisplayAsIcon:=False
    ' Temizlenecek
    Set WDDoc = Nothing
    Set WDApp = Nothing
 [COLOR="blue"]   ' Excelde Seçili alan kaldırılıyor.
    Application.CutCopyMode = False
    ActiveCell.Select[/COLOR]
End If
End Sub

 

[sirkülasyon]

elinize sağlık
Worde aktarma yaparken "Kaynak biçimlendirmesini Koru" şeklinde aktarabilir miyiz?

 

[alicimri]

"Kaynak biçimlendirmesini Koru" derken neyi kast ediyorsunuz daha doğrusu exceldeki verilerden örnek eklerseniz.

 

[sirkülasyon]

sayın alicimri
makro kod çalıştırmadan önce
Excel sayfasını kopyalayıp Word sayfasına geçip yapıştır derken "BAĞLA VE KAYNAK BİÇİMLENDİRMESİNİ KORU" seçeneği çıkıyor.

MAKRO KODU İLE
Aktarma yaparken bu seçenek ile yapıştırıp A4 sayfasını geçmeyecek şekilde tam sayfaya uyumlu olarak yapıştırması için yardımcı olabilir misiniz?

 

[alicimri]

Bağ yapıştır ile aktarıyor bu işinizi görür umarım.

Sub ExceldenWordeaktar()
' Microsoft Word Object Library kitaplığını aktif hale getirin
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
' Excelde bir aralık seçin
If Not TypeName(Selection) = "Range" Then
    MsgBox "Lütfen excel sayfasından aralığınızı seçiniz", vbExclamation, _
        "Hiçbir aralık seçilmedi"
Else
    ' Word belgeside açık olmalıdır
    Set WDApp = GetObject(, "Word.Application")
    ' Referans aktif doküman alınacak
    Set WDDoc = WDApp.ActiveDocument
      ' Eski tablo siliniyor
     
    If WDDoc.Tables.Count = 1 Then
   WDDoc.Tables(1).Delete
   End If
   ' Aralık kopyalanacak
    Selection.Copy
    ' Aralık yapıştırılacak
    WDApp.Selection.[COLOR="Blue"]PasteExcelTable True, False, False
[/COLOR]    ' Temizlenecek
    WDDoc.Tables(1).Select
    ' WDApp.Selection.Rows.ConvertToText Separator:=wdSeparateByParagraphs, _
      '  NestedTables:=True
    Set WDDoc = Nothing
    Set WDApp = Nothing
    ' Excelde Seçili alan kaldırılıyor.
    Application.CutCopyMode = False
    ActiveCell.Select
End If
End Sub

 

[sirkülasyon]

usta aktarma tamam. Ellerine sağlık.
Sayfaya sığması için bir şey yapılabilir mi?
Sayfaya sığarsa mükemmel olacak benim için.