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

[leumruk]

Hatayı alma sebebiniz muhtemelen word dosyasını seçememe ile ilgili seçili bir word dosyası olmadığı için hata alıyorsunuz. Word sayfasını açtıktan sonra aktif edebilmemiz gerekli. Bir de şu kodu deneyin: Yapıştırma satırından önce ekleyin:wd.activedocument.Range(0, 0).Select
Bu da olmazsa 2016 ile çalışan bir bilgisayarda deneme yapmam gerekli bu da bir kaç gün sonra olabilir. Bu süreçte deneme yapabilen arkadaşlarımız çözüm önerisinde bulunabilir.

 

[MURATSO]

Çok sağol uğraştın baya hakkını helal et. Bende bi pc yi kapatıp açayım he yolu denicem

 

[MURATSO]

eğer doğru anladıysam kodun son hail bu şekilde, eğer öyle ise Bu seferki hata run-time error '438': Object doesnt support this property or method
Aşağıdaki satırda
wd.Selection.ExcelTable False, True, False


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.ExcelTable False, True, False
wd.activedocument.Range(0, 0).Select
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]

wd.activedocument.Range(0, 0).Select
wd.Selection.MoveDown Unit:=5, Count:=1
wd.Selection.ExcelTable False, True, False

Bu şekilde olacak.

 

[MURATSO]

O şekilde de denedim yine aynı yerde hata veriyor

 

[MURATSO]

wd.activedocument.Range(0, 0).Select
wd.Selection.MoveDown Unit:=5, Count:=1
wd.Selection.ExcelTable False, True, False

Bu şekilde olacak.

Üstad şöyle birşey farkettim. Kodu f8 ile çalıştırırsam ve wd.documents.Add satırımda 2 saniye bekleyip devam edersem sorum yok ama makroya run dersem veya 2 saniye beklemeden f8 le ilerlersem wd.Selection.PasteExcelTable False, True, False satırında Run-time error '4198' Command failed hatası veriyor

 

[leumruk]

Üstad şöyle birşey farkettim. Kodu f8 ile çalıştırırsam ve wd.documents.Add satırımda 2 saniye bekleyip devam edersem sorum yok ama makroya run dersem veya 2 saniye beklemeden f8 le ilerlersem wd.Selection.PasteExcelTable False, True, False satırında Run-time error '4198' Command failed hatası veriyor

Aşağıdaki gibi deneyin çalışmama durumuna göre süreyi artırırsınız.

Sub WD_Aktar()
 'BA Bilgilendirme - Firma Adının ilk kelimesini
yol = Environ("USERPROFILE") & "\Desktop\"
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
Application.Wait (Now + TimeValue("0:00:02"))
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]

Hata kodu kullanmayı sevmesem de aşağıdaki şekilde de bir çözüm düşünülebilir.

Sub WD_Aktar()
 'BA Bilgilendirme - Firma Adının ilk kelimesini
yol = Environ("USERPROFILE") & "\Desktop\"
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
Tekrar:
On Error Resume Next
DoEvents
wd.Selection.PasteExcelTable False, True, False
If Err.Number > 0 Then GoTo Tekrar
On Error GoTo 0
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 gibi deneyin çalışmama durumuna göre süreyi artırırsınız.

Sub WD_Aktar()
'BA Bilgilendirme - Firma Adının ilk kelimesini
yol = Environ("USERPROFILE") & "\Desktop\"
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
Application.Wait (Now + TimeValue("0:00:02"))
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

Hocam bu kod çalıştı 3 saniye yapınca biraz yavaş ama olsun işimi gördü. Hata kodu olan son macro olduğu yerde loopa girdi hatadan çıkamadı o yüzden bunu kullandım. Eline emeğine sağlık. Hakkını helal et.

Birde eğer mümkünse ve bildiğin hazır mail gönderme macrosu varsa iletebilir misin.

Yapmak istediğim şu şekilde olacak
Aynı excelin diğer sayfasının A kolonunda bu firmaların tam isimleri B kolonunda da mail adresleri olacak. Subject konusu, mail gövdesinde yer alacak bilgi ile From ve cc kısmında olacak mail adresi kod içinde olabilir.

Yukarıdaki makroda ilgili firmaya ilşikin dosya hazırlandırğında önce mail atacak sonra klasöre kaydedecek şekilde. Eğer bunu da yapabilirsek duacınız olurum.

 

[leumruk]

Sn. Murat,
Forumun arama kısmından mail gönderme olarak arama yaptığınızda örnekler bulabilirsiniz. Bu başlıklardan yola çıkarak çözüm üretmeye çalışın takıldığınız yerler olursa ayrı bir başlık açıp yardım alabilirsiniz.

 

[MURATSO]

Sn. Murat,
Forumun arama kısmından mail gönderme olarak arama yaptığınızda örnekler bulabilirsiniz. Bu başlıklardan yola çıkarak çözüm üretmeye çalışın takıldığınız yerler olursa ayrı bir başlık açıp yardım alabilirsiniz.

Desteğin ve yardımlarınız için teşekkür ederim. Açıkçası makro bilgim yok ama yine de bakıp anlamaya çalışırım. En kötü sizin ilettiğiniz makro işe oluşan dosyaları tek tek kendim atıcam. Her raporda yaklaşıl 80-90 arasi firma oluyor, en azindan worde kopyalama işinden kurtardınız. Hakkınızı helal edin.
Hayırlı akşamlar.

 

[leumruk]

Sn. Murat,
Bugün office 2016 olan bir bilgisayarda denedim. Sizin aldığınız hatayı almadım. Alternatif olarak kodu hızlandıracak bir çözüm ürettim. Böyle daha hızlı çalışacaktır.

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