Soru VBA - Excel verilerini taratıp Word'e yazdırma

mftomas

New member
Üye
#1
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

New member
Üye
#2
#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
 

metehan8001

Feyzullah - Www.ExcelDepo.Com
Yönetici
Moderatör
#3
@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
 

metehan8001

Feyzullah - Www.ExcelDepo.Com
Yönetici
Moderatör
#4
Öncelikle: VBE'de tools-references'dan Microsoft Word 1x.0 Object Library işaretlenmelidir. Aksi halde hatalı davranır.
Kod:
Sub Hazirla()
'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
   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 con = CreateObject("adodb.Connection")
''''''''''''''''''''''''''''''''''''
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes""" ' hata verirse bunu pasif et, aşğıdakini kullan.
'H A T A   V E R İ R S E AŞAĞIDAKİNİ AKTİF ET
'con.Open "provider=microsoft.jet.oledb.4.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 8.0;hdr=yes""" ' hata verirse bunu aktif et.
'''''''''''''''''''''''''''''''
Set Kayit = CreateObject("ADODB.Recordset")
S = "SELECT distinct(eleman) FROM [Satışlar$] where Not isnull(eleman)"
Kayit.Open S, con, 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, con, 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
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(i, 2) > 100000 Then
Wrd.Selection.TypeText Text:=Cells(i, 1).Value & " yılında " & Format(Cells(i, 2).Value, "#,##0") & "TL üzeri satış yaptınız. Tebrik ederiz."
Wrd.Selection.TypeParagraph
End If
Next i
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
con.Close
MsgBox "İşlem tamamlandı, dosyalar kaydedildi", vbInformation + vbMsgBoxRtlReading, "Dosyalar hazırlandı."
End Sub
EKRAN GÖRÜNTÜSÜ

Ekran Alıntısı.PNG
 

Ekli dosyalar

mftomas

New member
Üye
#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 " :)
 

metehan8001

Feyzullah - Www.ExcelDepo.Com
Yönetici
Moderatör
#6
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.
 

metehan8001

Feyzullah - Www.ExcelDepo.Com
Yönetici
Moderatör
#7
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

New member
Üye
#8
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
 

metehan8001

Feyzullah - Www.ExcelDepo.Com
Yönetici
Moderatör
#9
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.
 

metehan8001

Feyzullah - Www.ExcelDepo.Com
Yönetici
Moderatör
#12
Dediğim gibi bende normal çalışıyor. Ben yinede kodlara ufak bir müdahale ettim. Yüklendiğim dosyayı indir dene.

Kod:
Sub Hazirla()
'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
   Sheets.Add After:=ActiveSheet
   sayfa = ActiveSheet.Name
   Sheets(sayfa).Range("A2:B12").Borders(xlDiagonalDown).LineStyle = xlNone
   Sheets(sayfa).Range("A2:B12").Borders(xlDiagonalUp).LineStyle = xlNone
   With Sheets(sayfa).Range("A2:B12").Borders(xlEdgeLeft)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Sheets(sayfa).Range("A2:B12").Borders(xlEdgeTop)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Sheets(sayfa).Range("A2:B12").Borders(xlEdgeBottom)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Sheets(sayfa).Range("A2:B12").Borders(xlEdgeRight)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Sheets(sayfa).Range("A2:B12").Borders(xlInsideVertical)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With
   With Sheets(sayfa).Range("A2:B12").Borders(xlInsideHorizontal)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
   End With

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

   Sheets(sayfa).Columns("B:B").ColumnWidth = 20.43: Sheets(sayfa).Range("B2:B12").NumberFormat = "#,##0_ ;-#,##0 "

Set con = CreateObject("adodb.Connection")
''''''''''''''''''''''''''''''''''''
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes""" ' hata verirse bunu pasif et, aşğıdakini kullan.
'H A T A   V E R İ R S E AŞAĞIDAKİNİ AKTİF ET
'con.Open "provider=microsoft.jet.oledb.4.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 8.0;hdr=yes""" ' hata verirse bunu aktif et.
'''''''''''''''''''''''''''''''
Set Kayit = CreateObject("ADODB.Recordset")
S = "SELECT distinct(eleman) FROM [Satışlar$] where Not isnull(eleman)"
Kayit.Open S, con, 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, con, 1, 3
If rs.RecordCount > 0 Then
Sheets(sayfa).Range("A2").CopyFromRecordset rs
End If
rs.Close
''''''''''''''''
Sheets(sayfa).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
For i = 2 To Sheets(sayfa).Cells(Rows.Count, 2).End(xlUp).Row
If Cells(i, 2) > 100000 Then
Wrd.Selection.TypeText Text:=Sheets(sayfa).Cells(i, 1).Value & " yılında " & Format(Sheets(sayfa).Cells(i, 2).Value, "#,##0") & "TL üzeri satış yaptınız. Tebrik ederiz."
Wrd.Selection.TypeParagraph
End If
Next i
Wrd.Selection.TypeParagraph
Sheets(sayfa).Range("a2:b" & Sheets(sayfa).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

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

Ekli dosyalar

metehan8001

Feyzullah - Www.ExcelDepo.Com
Yönetici
Moderatör
#14
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:
Üst