Excel Formül Sorusu Sor

Bir Excel formülüne dair sorunuz varsa, bu alanı kullanarak bize iletin.

Excel Makro Sorusu Sor

Bir Excel VBA koduna dair sorunuz varsa, bu alanı kullanarak bize iletin.

Genel Excel Sorusu Sor

Excel'in ön sayfasındaki FORMÜL haricinde olan sorularınızı buradan sorabilirsiniz.

Çözüldü Makro ile Excel Verilerini Word Programına Yazdırma

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

mftomas

Normal Üye

Excel Versiyonu
Excel 2016
Excel Sürümü
64 Bit
Excel Dili
Türkçe
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.webp
 

Ekli dosyalar

  • Satislar.xlsx
    264.9 KB · Görüntüleme: 4
Moderatörün son düzenlenenleri:
@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
 
Öncelikle: VBE'de tools-references'dan Microsoft Word 1x.0 Object Library işaretlenmelidir. Aksi halde hatalı davranır.
VBA:
Görüntülemek için giriş yapmalısınız.
(144 satır)

EKRAN GÖRÜNTÜSÜ

Ekran Alıntısı.webp
 

Ekli dosyalar

  • Satislar tomas.xlsx
    264.9 KB · Görüntüleme: 5
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 " :)
 
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.
 
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.
 
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.
 
Dediğim gibi bende normal çalışıyor. Ben yinede kodlara ufak bir müdahale ettim. Yüklendiğim dosyayı indir dene.

Kod:
Görüntülemek için giriş yapmalısınız.
(145 satır)
 

Ekli dosyalar

  • Satislar tomas.xlsm
    279.5 KB · Görüntüleme: 8
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 .webp
 
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
DMCA.com Protection Status
Konuyu başlatan
Normal Üye
Katılım
Konu Bilgi
Durum
Çözüldü 
Forum
Genel Excel Soruları
Başlangıç tarihi
Son yanıt tarihi
Cevaplar
15
Geri
Üst