Excel sayfasını word formatında kaydetmek

[mkuru28]

Merhaba arkadaşlar
Bir excel sayfasında B5:W55 aralığını word formatında masaüstüne kaydedebilecek bir koda ihtiyacım var. Yardımcı olabilecek tüm arkadaşlara şimdiden teşekkür ederim.

 

[nihatkr]

Merhaba,
Aşağıdaki Kodu Modül Olarak Kaydedin. Bir düğme atayın.

Seçeceğiniz alanı İster Tablo, İster Resim Olarak Worde Aktarın. (İstediğiniz alanı Seçim Olarak Belirleyebilirsiniz)


Option Explicit

Sub ExportSelectedRangeToWord_Flexible()
Dim rng As Range
Dim wdApp As Object
Dim wdDoc As Object
Dim userChoice As Variant

On Error Resume Next
Set rng = Application.InputBox("Word'e aktarmak istediğiniz aralığı seçin:", "Aralık Seç", Type:=8)
On Error GoTo 0

If rng Is Nothing Then
MsgBox "Hiçbir aralık seçilmedi. İşlem iptal edildi.", vbExclamation
Exit Sub
End If

userChoice = MsgBox("Seçili aralığı Word'de tablo olarak mı aktarmak istiyorsunuz?" & vbCrLf & _
"Evet = Tablo, Hayır = Resim", vbYesNoCancel + vbQuestion, "Aktarım Seçimi")
If userChoice = vbCancel Then Exit Sub

On Error Resume Next
Set wdApp = GetObject(Class:="Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject(Class:="Word.Application")
On Error GoTo 0
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add

If userChoice = vbYes Then
rng.Copy
With wdDoc.Content
.Collapse Direction:=0
.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
.InsertParagraphAfter
End With
MsgBox "Aralık Word'e tablo olarak aktarıldı.", vbInformation
Else
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
wdDoc.Content.Paste
MsgBox "Aralık Word'e resim olarak aktarıldı.", vbInformation
End If

Set rng = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub

 

[mkuru28]

Hocam çok teşekkür ederim. Emeğinize sağlık..

 

[nihatkr]

Hocam çok teşekkür ederim. Emeğinize sağlık..

Rica Ederim. sorun Çözüldü