#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