Sitemize Hoşgeldiniz

Türkiye'nin en geniş özeliklere sahip forumu olan ExcelDestek.Com üzerinde soru sorabilmek, daha önceki sorulan sorulara, açılan konulara cevap yazabilmek, puan kazanabilmek, kazandığınız puanlar ile dosya indirebilmek ve çok daha fazla özellikten yararlanabilmek için sitemize üye olunuz.
Hemen Üye Ol ya da Giriş Yap

Sorun Cevaplayalım

Excel'e dair sorularınızı sorun, cevaplayalım.

Çözümlenmiş Sorular

Kullanıcılarımızın sorularını ve sunduğumuz çözümleri inceleyin.

Destek Ekibimiz Sizlerle

Ücretli destek ve özel hizmet talep edebilirsiniz.

Makrolar Çözüldü VBA - Excel verilerini taratıp Word'e yazdırma

Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...

mftomas

Yeni Üye
Kullanıcı
Katılım
21 Ara 2018
Mesajlar
7
Excel Versiyonu, Dili
Bilinmiyor

Reputation:

Günlerdir bu uygulama için uğraşıyorum araştırıyorum ancak kayda değer bir şey bulamadım. Yardımcı olursanız çok sevinicem.

"Satislar.xlsx" Excel çalışma kitabındaki satış kayıtlarını tarayarak, her satış elemanına hitaben, ekte bulunan "OrnekDokum.docx" belgesinin bir kopyasını oluşturmak için bir VBA fonksiyonu yazmaya çalışıyorum. Bu fonksiyon oluşturduğu döküm kopyasındaki tabloya ilgili elemanın yıllık satış toplamlarını yerleştireceğim, eleman her yıl 100bin TL üstü satış yapmışsa tablodan sonraki bir paragrafta bunu belirtip elemanı tebrik eden ifadeler eklemelidir.
Bu işin çözümü Excel VBA projesinden Word programını açıp Excel açıkken Word belgeleri oluşturmayı gerektirecek.
Adsız.png
 

Ekli dosyalar

MemoliPayne

Yeni Üye
Kullanıcı
Katılım
19 Ara 2018
Mesajlar
1
Excel Versiyonu, Dili
Bilinmiyor

Reputation:

#If VBA7 Then
Const oledbX As String = "Microsoft.ACE.OLEDB.12.0"
Const propX As String = "Excel 12.0"
#Else
Const oledbX As String = "Microsoft.Jet.OLEDB.4.0"
Const propX As String = "Excel 8.0"
#End If
Public Baglan As Object
Public Sub Baglanti_Yap()
Set Baglan = Nothing
Set Baglan = CreateObject("adodb.connection")
constr = "provider=" & oledbX & ";data source=" & ThisWorkbook.FullName & ";extended properties=""" & propX & ";hdr=yes"""
Baglan.connectionstring = constr
Baglan.Open
End Sub

Sub BaSLAT()
'VBE'de tools-references'dan Microsoft Word 14.0 Object Library işaretlenmelidir.
'VBE'de tools-references'dan Microsoft Word 1x.0 Object Library işaretlenmelidir.
Dim Wrd As Word.Application
Dim doc As Word.document
Call Baglanti_Yap
Sheets.Add After:=ActiveSheet
Range("A2:B12").Borders(xlDiagonalDown).LineStyle = xlNone
Range("A2:B12").Borders(xlDiagonalUp).LineStyle = xlNone
With Range("A2:B12").Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("A2:B12").Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("A2:B12").Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("A2:B12").Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("A2:B12").Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("A2:B12").Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With Range("A2:B12")
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Columns("B:B").ColumnWidth = 20.43: Range("B2:B12").NumberFormat = "#,##0_ ;-#,##0 "
''''
Set Kayit = CreateObject("ADODB.Recordset")
S = "SELECT distinct(eleman) FROM [Satışlar$] where Not isnull(eleman)"
Kayit.Open S, Baglan, 1, 3
If Kayit.RecordCount > 0 Then
Do While Not Kayit.EOF
personel = Kayit(0).Value
Set rs = CreateObject("ADODB.Recordset")
Sorgu = "SELECT year(Tarih), sum(tutar) FROM [Satışlar$] where (eleman)= '" & personel & "' group by year(Tarih)"
rs.Open Sorgu, Baglan, 1, 3
If rs.RecordCount > 0 Then
Range("A2").CopyFromRecordset rs
End If
rs.Close
''''''''''''''''
Range("a2:b" & Cells(Rows.Count, 2).End(xlUp).Row).Copy
Set Wrd = CreateObject("Word.Application")
Set doc = Wrd.documents.Add
Wrd.Visible = True
'With Wrd.Selection
Wrd.Selection.Font.Size = 16
Wrd.Selection.Font.Bold = wdToggle
Wrd.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Wrd.Selection.TypeText Text:="SATIŞ ELEMANI YILLIK SATIŞ TOPLAMLARI"
Wrd.Selection.TypeParagraph
Wrd.Selection.Font.Bold = wdToggle
Wrd.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
Wrd.Selection.TypeParagraph
Wrd.Selection.Font.Size = 11
Wrd.Selection.TypeText Text:="Sayın " & personel
Wrd.Selection.TypeParagraph
Wrd.Selection.TypeText Text:= _
"Kurumumuz adına yaptığınız yıllık satış toplamları aşağıdaki tabloda sunulmuştur."
Wrd.Selection.TypeParagraph
Wrd.Selection.TypeParagraph
Range("a2:b" & Cells(Rows.Count, 2).End(xlUp).Row).Copy
'On Error Resume Next
Wrd.Selection.Paste
'Debug.Print Err
'End With
Wrd.ActiveDocument.Tables(1).Rows.HeightRule = wdRowHeightExactly
On Error Resume Next
Wrd.ActiveDocument.Tables(1).Rows.Height = CentimetersToPoints(0.63)
If Not Err.Number = "0" Then Wrd.ActiveDocument.Tables(1).Rows.Height = "0.16": Err.Clear

Wrd.ActiveDocument.Tables(1).Columns(1).Select
Wrd.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

Wrd.ActiveDocument.Tables(1).Columns(1).PreferredWidthType = wdPreferredWidthPoints
On Error Resume Next
Wrd.ActiveDocument.Tables(1).Columns(1).PreferredWidth = CentimetersToPoints(2)
If Not Err.Number = "0" Then Wrd.ActiveDocument.Tables(1).Columns(1).PreferredWidth = "0.60": Err.Clear

Wrd.ActiveDocument.Tables(1).Columns(2).PreferredWidthType = wdPreferredWidthPoints
Wrd.ActiveDocument.Tables(1).Columns(2).PreferredWidth = CentimetersToPoints(6)
If Not Err.Number = "0" Then Wrd.ActiveDocument.Tables(1).Columns(2).PreferredWidth = "1.10": Err.Clear
On Error GoTo 0
Wrd.ActiveDocument.Tables(1).Rows.Alignment = wdAlignRowCenter
Wrd.Selection.MoveDown Unit:=wdLine, Count:=1

doc.SaveAs ThisWorkbook.Path & "\" & personel & ".docx", FileFormat:=wdFormatDocumentDefault
doc.Close
Wrd.Quit

'''''''''''''''''
Range("a2").CurrentRegion.ClearContents
Kayit.movenext
Loop
End If
Kayit.Close
MsgBox "İşlem tamamlandı, dosyalar kaydedildi", vbInformation + vbMsgBoxRtlReading, "Dosyalar hazırlandı."
End Sub
 

Feyzullah

XD Yönetim
Yönetici
Site Yöneticisi
SMS Onaylı
Katılım
1 Eki 2018
Mesajlar
632
Web Sitesi
www.exceldepo.com
Excel Versiyonu, Dili
Excel 2016 TR

Reputation:

@MemoliPayne alıntı olduğunu belirtseydin keşke :). Neyse yapmış olduğum bu çalışmanın 2.versiyonunu atıyorum. Her yıl için özel tebrik yazıyor. ADO bağlantı kodlarını sadeleştirdim.

#If VBA7 Then
Const oledbX As String = "Microsoft.ACE.OLEDB.12.0"
Const propX As String = "Excel 12.0"
#Else
Const oledbX As String = "Microsoft.Jet.OLEDB.4.0"
Const propX As String = "Excel 8.0"
#End If
Public Baglan As Object
Public Sub Baglanti_Yap()
Set Baglan = Nothing
Set Baglan = CreateObject("adodb.connection")
constr = "provider=" & oledbX & ";data source=" & ThisWorkbook.FullName & ";extended properties=""" & propX & ";hdr=yes"""
Baglan.connectionstring = constr
Baglan.Open
End Sub

Sub BaSLAT()
'VBE'de tools-references'dan Microsoft Word 14.0 Object Library işaretlenmelidir.
'VBE'de tools-references'dan Microsoft Word 1x.0 Object Library işaretlenmelidir.
Dim Wrd As Word.Application
Dim doc As Word.document
Call Baglanti_Yap
Sheets.Add After:=ActiveSheet
Range("A2:B12").Borders(xlDiagonalDown).LineStyle = xlNone
Range("A2:B12").Borders(xlDiagonalUp).LineStyle = xlNone
With Range("A2:B12").Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("A2:B12").Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("A2:B12").Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("A2:B12").Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("A2:B12").Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("A2:B12").Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With

With Range("A2:B12")
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Columns("B:B").ColumnWidth = 20.43: Range("B2:B12").NumberFormat = "#,##0_ ;-#,##0 "
''''
Set Kayit = CreateObject("ADODB.Recordset")
S = "SELECT distinct(eleman) FROM [Satışlar$] where Not isnull(eleman)"
Kayit.Open S, Baglan, 1, 3
If Kayit.RecordCount > 0 Then
Do While Not Kayit.EOF
personel = Kayit(0).Value
Set rs = CreateObject("ADODB.Recordset")
Sorgu = "SELECT year(Tarih), sum(tutar) FROM [Satışlar$] where (eleman)= '" & personel & "' group by year(Tarih)"
rs.Open Sorgu, Baglan, 1, 3
If rs.RecordCount > 0 Then
Range("A2").CopyFromRecordset rs
End If
rs.Close
''''''''''''''''
Range("a2:b" & Cells(Rows.Count, 2).End(xlUp).Row).Copy
Set Wrd = CreateObject("Word.Application")
Set doc = Wrd.documents.Add
Wrd.Visible = True
'With Wrd.Selection
Wrd.Selection.Font.Size = 16
Wrd.Selection.Font.Bold = wdToggle
Wrd.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Wrd.Selection.TypeText Text:="SATIŞ ELEMANI YILLIK SATIŞ TOPLAMLARI"
Wrd.Selection.TypeParagraph
Wrd.Selection.Font.Bold = wdToggle
Wrd.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
Wrd.Selection.TypeParagraph
Wrd.Selection.Font.Size = 11
Wrd.Selection.TypeText Text:="Sayın " & personel
Wrd.Selection.TypeParagraph
Wrd.Selection.TypeText Text:= _
"Kurumumuz adına yaptığınız yıllık satış toplamları aşağıdaki tabloda sunulmuştur."
Wrd.Selection.TypeParagraph
Wrd.Selection.TypeParagraph
Range("a2:b" & Cells(Rows.Count, 2).End(xlUp).Row).Copy
'On Error Resume Next
Wrd.Selection.Paste
'Debug.Print Err
'End With
Wrd.ActiveDocument.Tables(1).Rows.HeightRule = wdRowHeightExactly
On Error Resume Next
Wrd.ActiveDocument.Tables(1).Rows.Height = CentimetersToPoints(0.63)
If Not Err.Number = "0" Then Wrd.ActiveDocument.Tables(1).Rows.Height = "0.16": Err.Clear

Wrd.ActiveDocument.Tables(1).Columns(1).Select
Wrd.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

Wrd.ActiveDocument.Tables(1).Columns(1).PreferredWidthType = wdPreferredWidthPoints
On Error Resume Next
Wrd.ActiveDocument.Tables(1).Columns(1).PreferredWidth = CentimetersToPoints(2)
If Not Err.Number = "0" Then Wrd.ActiveDocument.Tables(1).Columns(1).PreferredWidth = "0.60": Err.Clear

Wrd.ActiveDocument.Tables(1).Columns(2).PreferredWidthType = wdPreferredWidthPoints
Wrd.ActiveDocument.Tables(1).Columns(2).PreferredWidth = CentimetersToPoints(6)
If Not Err.Number = "0" Then Wrd.ActiveDocument.Tables(1).Columns(2).PreferredWidth = "1.10": Err.Clear
On Error GoTo 0
Wrd.ActiveDocument.Tables(1).Rows.Alignment = wdAlignRowCenter
Wrd.Selection.MoveDown Unit:=wdLine, Count:=1

doc.SaveAs ThisWorkbook.Path & "\" & personel & ".docx", FileFormat:=wdFormatDocumentDefault
doc.Close
Wrd.Quit

'''''''''''''''''
Range("a2").CurrentRegion.ClearContents
Kayit.movenext
Loop
End If
Kayit.Close
MsgBox "İşlem tamamlandı, dosyalar kaydedildi", vbInformation + vbMsgBoxRtlReading, "Dosyalar hazırlandı."
End Sub
 

Feyzullah

XD Yönetim
Yönetici
Site Yöneticisi
SMS Onaylı
Katılım
1 Eki 2018
Mesajlar
632
Web Sitesi
www.exceldepo.com
Excel Versiyonu, Dili
Excel 2016 TR

Reputation:

Öncelikle: VBE'de tools-references'dan Microsoft Word 1x.0 Object Library işaretlenmelidir. Aksi halde hatalı davranır.
PHP:
Değerli ziyaretçimiz lütfen, içeriği görüntüleyebilmek için Giriş Yap veya Kayıt Ol anlayışınız için teşekkürler.
EKRAN GÖRÜNTÜSÜ

Ekran Alıntısı.PNG
 

Ekli dosyalar

Son düzenleme:

mftomas

Yeni Üye
Kullanıcı
Katılım
21 Ara 2018
Mesajlar
7
Excel Versiyonu, Dili
Bilinmiyor

Reputation:

Tebrik mesajları alt alta liste olarak sıralanıyor. Sıralaması bittiğinde (uzun bir sıralama) word'ü kapatıp yeni word açıyor ve tebrik için tablo oluşturup tekrar kapatıyor. Hepsi tamamlanana kadar sayısız word dosyası açıp tablo oluşturup kapatıyor.

Tebrik mesajları da şöyle, "İstanbul yılında TL üzeri satış yaptınız. Tebrik ederiz " :)
 

Feyzullah

XD Yönetim
Yönetici
Site Yöneticisi
SMS Onaylı
Katılım
1 Eki 2018
Mesajlar
632
Web Sitesi
www.exceldepo.com
Excel Versiyonu, Dili
Excel 2016 TR

Reputation:

Yukarıda bir ekran görüntüsü atmıştım, gördün mü onu. bende öyle çıkıyor tebrik mesajları. Kapatıp açma işine de gelince her personele özel doc oluşturup kapatıyor.
 

Feyzullah

XD Yönetim
Yönetici
Site Yöneticisi
SMS Onaylı
Katılım
1 Eki 2018
Mesajlar
632
Web Sitesi
www.exceldepo.com
Excel Versiyonu, Dili
Excel 2016 TR

Reputation:

Sütün başlıklarını kontrol et. İlgili sütun başlığının altında ilgili veriler olması gerek. Yani sütun başlıklarını baz alarak yapıyor.
 

mftomas

Yeni Üye
Kullanıcı
Katılım
21 Ara 2018
Mesajlar
7
Excel Versiyonu, Dili
Bilinmiyor

Reputation:

Benimkinde Microsoft Word 1x.0 Object Library yoktu. Bende Microsoft Word 12 Object Library vardı onu işaretledim. Problem bundan çıkıyor olamaz değil mi?

Sütün başlıklarını kontrol et. İlgili sütun başlığının altında ilgili veriler olması gerek. Yani sütun başlıklarını baz alarak yapıyor.
Kontrol edeyim bi hemen
 

Feyzullah

XD Yönetim
Yönetici
Site Yöneticisi
SMS Onaylı
Katılım
1 Eki 2018
Mesajlar
632
Web Sitesi
www.exceldepo.com
Excel Versiyonu, Dili
Excel 2016 TR

Reputation:

Benimkinde Microsoft Word 1x.0 Object Library yoktu. Bende Microsoft Word 12 Object Library vardı onu işaretledim. Problem bundan çıkıyor olamaz değil mi?
Yok bundan dolayı yapmaz.
Microsoft Word 12.0 Object Library
Microsoft Word 13.0 Object Library
Microsoft Word 14.0 Object Library
Microsoft Word 15.0 Object Library
Microsoft Word 16.0 Object Library
hangisi varsa onu işaretle.
 

mftomas

Yeni Üye
Kullanıcı
Katılım
21 Ara 2018
Mesajlar
7
Excel Versiyonu, Dili
Bilinmiyor

Reputation:

Range("A2:B12") derken tam anlayamadım açıkçası. Çıktım böyle Aadsız.png
 

Feyzullah

XD Yönetim
Yönetici
Site Yöneticisi
SMS Onaylı
Katılım
1 Eki 2018
Mesajlar
632
Web Sitesi
www.exceldepo.com
Excel Versiyonu, Dili
Excel 2016 TR

Reputation:

Dediğim gibi bende normal çalışıyor. Ben yinede kodlara ufak bir müdahale ettim. Yüklendiğim dosyayı indir dene.

Kod:
Değerli ziyaretçimiz lütfen, içeriği görüntüleyebilmek için Giriş Yap veya Kayıt Ol anlayışınız için teşekkürler.
 

Ekli dosyalar

mftomas

Yeni Üye
Kullanıcı
Katılım
21 Ara 2018
Mesajlar
7
Excel Versiyonu, Dili
Bilinmiyor

Reputation:

Bende word 16 olmadığından dolayı 12 yi aktif ettim ancak böyle bir hata ile karşılaştım
Adsız.png
 

Feyzullah

XD Yönetim
Yönetici
Site Yöneticisi
SMS Onaylı
Katılım
1 Eki 2018
Mesajlar
632
Web Sitesi
www.exceldepo.com
Excel Versiyonu, Dili
Excel 2016 TR

Reputation:

16 olması önemli değil hangisi varsa onu yapacaksın ve dosyayı pc başında arkadaşa gönderdim normal çalışıyor bilgisini verdi.

Makroların çalışması için güvenlik düzeyini düşüğe ayarlamak gerekiyor.
Excelde makroları etkin kılmak için.
*Önce araçları seçelim.
*Makro>Güvenlik seçelim.
*En sondaki düşük önerilmez seçip ve tamam tuşuna basalım.
Exceli kapatıp tekrar açalım.

Dosyayı ilk açtığında içeriği ve makroyu etkinleştireceksin.

İçerik .PNG
 
Son düzenleme:

mftomas

Yeni Üye
Kullanıcı
Katılım
21 Ara 2018
Mesajlar
7
Excel Versiyonu, Dili
Bilinmiyor

Reputation:

Dediğinizi yaptım ve bu defa sorunsuz çalıştı. Çok teşekkür ederim gerçekten. Allah razı olsun
 
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Üst