Exelde yer alan bilgiyi Worde alıp isim vererek masaüstüne kaydetmek

[MURATSO]

Merhaba bir sistemden excel rapor çekiyorum . Çektiğim excel raporunda firma firma bilgiler var. ben bu bilgileri aynı göründüğü şekilde tek tek kopyalayım bir word dosyasına alıyor, dosya adını da BA BİLDİRİM yazıp yanına da - koyup firmanın (Sayın kısmında yazan) ilk kelimesini ekleyip kaydediyorum. her firma bilgisi standan 3 kolon ve toplam 18 satır olarak ve bazı satır ve kolonları birleşik olarak geliyor. iki firma arasında da standart 25 satır var. Örnek dosya ekledim. bu liste bazen 10 bazen 50 olabiliyor. Bu işi yapacak bir makro yazılabilir mi? şimdiden teşekkür ederim.
örnek dosya

 

[MURATSO]

Müsait olan bir üstad bakabilirse çok sevinirim. Her ay 80 90 kez copy paste mahvediyor valla.
Çok teşekkürler şimdiden.

 

[leumruk]

Müsait olan bir üstad bakabilirse çok sevinirim. Her ay 80 90 kez copy paste mahvediyor valla.
Çok teşekkürler şimdiden.

Sn Murat,
Sorunuz anlaşılmıyor. Excel tablosunu worde aktarmak mümkün. Ancak örnek dosyanızda 1 tane tablo var. Tablodaki bilgiler de herhangi bir değişkene atanmamış. Aynı tabloyu sürekli yazdırmak istemediğiniz belli, ancak neleri yazdıracağımız belirsiz.

 

[MURATSO]

Selam aslinda tek tablo yok, her tablo arasında boş 25 satır var. Aşağıya doğru inilirse görülecektir. Her tabloda başka firma bilgileri var. Istediğim şey ise her firmaya ait tabloyu ayrı bir Word'e almak ve word'ü masaüstüne kaydederken dosya adına BA Bilgilendirme - Firma Adının ilk kelimesini yazsın istiyorum.

 

[leumruk]

Selam aslinda tek tablo yok, her tablo arasında boş 25 satır var. Aşağıya doğru inilirse görülecektir. Her tabloda başka firma bilgileri var. Istediğim şey ise her firmaya ait tabloyu ayrı bir Word'e almak ve word'ü masaüstüne kaydederken dosya adına BA Bilgilendirme - Firma Adının ilk kelimesini yazsın istiyorum.

Verdiğiniz ölçütlere göre bir dosya hazırladım. Ölçütlerde değişiklik olma ihtimali varsa satır ya da sütun farklılıkları gibi daha esnek bir kod hazırlamak gerekir. Word dosyalarını bu dosyanın bulunduğu klasöre kaydeder. Masaüstüne kaydetmek için yol tanımını yol = Environ("USERPROFILE") & "\Desktop\" ile değitirebilirsiniz.

Sub WD_Aktar()
'BA Bilgilendirme - Firma Adının ilk kelimesini
yol = ThisWorkbook.Path & "\"
Set wd = CreateObject("Word.Application")
wd.Visible = True
sonsat = Cells(Rows.Count, 1).End(3).Row
For x = 1 To sonsat Step 43
Range("a" & x & ":c" & x + 17).Copy
wd.documents.Add
wd.Selection.PasteExcelTable False, True, False
dosya = "BA Bilgilendirme - " & Split(Trim(Range("b" & x + 1)), " ")(0)
wd.activedocument.SaveAs yol & dosya
wd.activedocument.Close False
Next
wd.Application.Quit
Application.CutCopyMode = False
MsgBox "Aktarma işlemi tamamlandı.", vbOKOnly, "l e u m r u k"
End Sub

 

[MURATSO]

aşağıdaki alanda hata verdi

wd.Selection.PasteExcelTable False, True, False

 

[leumruk]

Muhtemelen office versiyonuyla ilgili, bende çalışıyor. Hata veren satır yerine şu iki satırı yapıştırın:

wd.Selection.Paste
wd.Selection.Tables(1).AutoFitBehavior (2)

 

[MURATSO]

şimdide aşağıdaki alanda hata verdi. Benim word 2016

wd.Selection.Paste


Sub WD_Aktar()
'BA Bilgilendirme - Firma Adının ilk kelimesini
yol = ThisWorkbook.Path & "\"
Set wd = CreateObject("Word.Application")
wd.Visible = True
sonsat = Cells(Rows.Count, 1).End(3).Row
For x = 1 To sonsat Step 43
Range("a" & x & ":c" & x + 17).Copy
wd.documents.Add
wd.Selection.Paste
wd.Selection.Tables(1).AutoFitBehavior (2)
dosya = "BA Bilgilendirme - " & Split(Trim(Range("b" & x + 1)), " ")(0)
wd.activedocument.SaveAs yol & dosya
wd.activedocument.Close False
Next
wd.Application.Quit
Application.CutCopyMode = False
MsgBox "Aktarma işlemi tamamlandı.", vbOKOnly, "l e u m r u k"
End Sub

 

[leumruk]

Son verdiğim satır yerine bir de şunu deneyin: wd.Selection.PasteAppendTable
Bu da olmazsa hata mesajını ve kodunu yazın araştıralım. Bende 2016 olmadığı için deneme şansım yok.

 

[halit3]

Kod ofis 2016 64 bit te çalışıyor.
birde şunu dene

wd.Selection.PasteExcelTable False, True, False

yukarıdaki yeri aşağıdaki ile değiştirip denermisiniz.

wd.ActiveDocument.Paragraphs(1).Range.Paste

 

[MURATSO]

hata kodu şu şekilde = Run-time error '4605' This command is not available
hata veren satır = wd.Selection.PasteAppendTable
koduda aşağıdaki şekilde çalıştırdım

Sub WD_Aktar()
'BA Bilgilendirme - Firma Adının ilk kelimesini
yol = ThisWorkbook.Path & "\"
Set wd = CreateObject("Word.Application")
wd.Visible = True
sonsat = Cells(Rows.Count, 1).End(3).Row
For x = 1 To sonsat Step 43
Range("a" & x & ":c" & x + 17).Copy
wd.documents.Add
wd.Selection.PasteAppendTable
dosya = "BA Bilgilendirme - " & Split(Trim(Range("b" & x + 1)), " ")(0)
wd.activedocument.SaveAs yol & dosya
wd.activedocument.Close False
Next
wd.Application.Quit
Application.CutCopyMode = False
MsgBox "Aktarma işlemi tamamlandı.", vbOKOnly, "l e u m r u k"
End Sub

Kod ofis 2016 64 bit te çalışıyor.
birde şunu dene

wd.Selection.PasteExcelTable False, True, False

yukarıdaki yeri aşağıdaki ile değiştirip denermisiniz.

wd.ActiveDocument.Paragraphs(1).Range.Paste

hata kodu şu şekilde = Run-time error '5097' Word has encıuntered a problem
hata veren satır = wd.ActiveDocument.Paragraphs(1).Range.Paste
kodu aşağıdaki şekilde çalıştırdım

Sub WD_Aktar()
'BA Bilgilendirme - Firma Adının ilk kelimesini
yol = ThisWorkbook.Path & "\"
Set wd = CreateObject("Word.Application")
wd.Visible = True
sonsat = Cells(Rows.Count, 1).End(3).Row
For x = 1 To sonsat Step 43
Range("a" & x & ":c" & x + 17).Copy
wd.documents.Add
wd.ActiveDocument.Paragraphs(1).Range.Paste
dosya = "BA Bilgilendirme - " & Split(Trim(Range("b" & x + 1)), " ")(0)
wd.ActiveDocument.SaveAs yol & dosya
wd.ActiveDocument.Close False
Next
wd.Application.Quit
Application.CutCopyMode = False
MsgBox "Aktarma işlemi tamamlandı.", vbOKOnly, "l e u m r u k"
End Sub

 

[leumruk]

Sayın Murat,
Excel dosyanızdaki tablonuzdan birini manuel olarak kopyalayın, ardından word dosyanızın geliştirici sekmesinden makro kaydeti çalıştırıp tabloyu word dosyanıza yapıştırın. Makro kaydeti durdurun. Elde ettiğiniz kodu gönderin düzenleyeyim.

 

[MURATSO]

bu şekilde geldi

Sub deneme()
'
' deneme Macro
'
'
Selection.PasteExcelTable False, False, False
End Sub

 

[MURATSO]

Birde tabioyu yapıştırınca ortalama ve hizalama da eklenebilir mi

 

[leumruk]

İlk eklediğim koddaki yapıştırma türü. Aşağıdaki şekilde deneyin:

wd.Selection.MoveDown Unit:=5, Count:=1
wd.Selection.ExcelTable False, True, False

 

[MURATSO]

exceldeki ilk 2 firma için çok güzel çalıştı ama sonra aşağıdaki satırda şu hatayı verdi Run-tşme error '4198' Command Failed

wd.Selection.PasteExcelTable False, True, False

kodum tam hali bu

Sub WD_Aktar()
'BA Bilgilendirme - Firma Adının ilk kelimesini
yol = ThisWorkbook.Path & "\"
Set wd = CreateObject("Word.Application")
wd.Visible = True
sonsat = Cells(Rows.Count, 1).End(3).Row
For x = 1 To sonsat Step 43
Range("a" & x & ":c" & x + 17).Copy
wd.documents.Add
wd.Selection.MoveDown Unit:=5, Count:=1
wd.Selection.PasteExcelTable False, True, False
dosya = "BA Bilgilendirme - " & Split(Trim(Range("b" & x + 1)), " ")(0)
wd.activedocument.SaveAs yol & dosya
wd.activedocument.Close False
Next
wd.Application.Quit
Application.CutCopyMode = False
MsgBox "Aktarma işlemi tamamlandı.", vbOKOnly, "l e u m r u k"
End Sub

 

[leumruk]

Yapıştırma kodunda mı farklı bir satır da mı hata verdi. Benim ilk eklediğim örnek dosyada hata veriyor mu?

 

[MURATSO]

ilk gönderdiğiniz dosyada yapıyorum sadece alttaki satırda veriyor hatayı

wd.Selection.PasteExcelTable False, True, False

 

[MURATSO]

Yani ilk macro koduna ekledim verdığınız yapıştırma kodunu yapıştırma kodunda verdi

 

[leumruk]

Yapıştırma kodları için şu an başka önerim yok. Hatayı kavrayabilmek için aynı hatayı yaşamam lâzım. Gönderdiğim hiçbir kodda hata almadım. SaveAs kodunda hata yaşıyorsanız özel karakterlerle ilgili bir durum olabilir. İkinokta) gibi