• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

M

MURATSO

Katılım
3 Nisan 2014
Mesajlar
173
Excel Vers. ve Dili
excel 2010
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
 
Müsait olan bir üstad bakabilirse çok sevinirim. Her ay 80 90 kez copy paste mahvediyor valla. :(
Çok teşekkürler şimdiden.
 
MURATSO' Alıntı:
Müsait olan bir üstad bakabilirse çok sevinirim. Her ay 80 90 kez copy paste mahvediyor valla. :(
Çok teşekkürler şimdiden.
Genişletmek için tıkla ...
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.
 
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.
 
MURATSO' Alıntı:
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.
Genişletmek için tıkla ...
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.
C++: 
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
 

Ekli dosyalar

Son düzenleme:
aşağıdaki alanda hata verdi

wd.Selection.PasteExcelTable False, True, False
 
Muhtemelen office versiyonuyla ilgili, bende çalışıyor. Hata veren satır yerine şu iki satırı yapıştırın:
C++: 
wd.Selection.Paste
wd.Selection.Tables(1).AutoFitBehavior (2)
 
ş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
 
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.
 
Kod ofis 2016 64 bit te çalışıyor.
birde şunu dene

Kod: 
wd.Selection.PasteExcelTable False, True, False
yukarıdaki yeri aşağıdaki ile değiştirip denermisiniz.

Kod: 
wd.ActiveDocument.Paragraphs(1).Range.Paste
 
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
halit3' Alıntı:
Kod ofis 2016 64 bit te çalışıyor.
birde şunu dene

Kod: 
wd.Selection.PasteExcelTable False, True, False
yukarıdaki yeri aşağıdaki ile değiştirip denermisiniz.

Kod: 
wd.ActiveDocument.Paragraphs(1).Range.Paste
Genişletmek için tıkla ...

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
 
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.
 
bu şekilde geldi

Sub deneme()
'
' deneme Macro
'
'
Selection.PasteExcelTable False, False, False
End Sub
 
Birde tabioyu yapıştırınca ortalama ve hizalama da eklenebilir mi
 
İlk eklediğim koddaki yapıştırma türü. Aşağıdaki şekilde deneyin:
Kod: 
wd.Selection.MoveDown Unit:=5, Count:=1
wd.Selection.ExcelTable False, True, False
 
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
 
Yapıştırma kodunda mı farklı bir satır da mı hata verdi. Benim ilk eklediğim örnek dosyada hata veriyor mu?
 
ilk gönderdiğiniz dosyada yapıyorum sadece alttaki satırda veriyor hatayı

wd.Selection.PasteExcelTable False, True, False
 
Yani ilk macro koduna ekledim verdığınız yapıştırma kodunu yapıştırma kodunda verdi
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst